diff --git a/pkgs/racket-doc/scribblings/raco/zo-struct.scrbl b/pkgs/racket-doc/scribblings/raco/zo-struct.scrbl index 478d15297d..f5d5efabe8 100644 --- a/pkgs/racket-doc/scribblings/raco/zo-struct.scrbl +++ b/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) ()] )]{ diff --git a/pkgs/racket-test-core/tests/racket/optimize.rktl b/pkgs/racket-test-core/tests/racket/optimize.rktl index dece1e3213..47b50ee1d5 100644 --- a/pkgs/racket-test-core/tests/racket/optimize.rktl +++ b/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)))) diff --git a/pkgs/zo-lib/compiler/zo-marshal.rkt b/pkgs/zo-lib/compiler/zo-marshal.rkt index d2d55248f3..e969984570 100644 --- a/pkgs/zo-lib/compiler/zo-marshal.rkt +++ b/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]) diff --git a/pkgs/zo-lib/compiler/zo-parse.rkt b/pkgs/zo-lib/compiler/zo-parse.rkt index 43b13a813c..baae6869a8 100644 --- a/pkgs/zo-lib/compiler/zo-parse.rkt +++ b/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 diff --git a/pkgs/zo-lib/compiler/zo-structs.rkt b/pkgs/zo-lib/compiler/zo-structs.rkt index a38134be23..251e41c752 100644 --- a/pkgs/zo-lib/compiler/zo-structs.rkt +++ b/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: diff --git a/racket/src/racket/src/compenv.c b/racket/src/racket/src/compenv.c index 77f85b7900..ba0c34a7e4 100644 --- a/racket/src/racket/src/compenv.c +++ b/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 diff --git a/racket/src/racket/src/eval.c b/racket/src/racket/src/eval.c index 8bb7e0947a..238e421167 100644 --- a/racket/src/racket/src/eval.c +++ b/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]; diff --git a/racket/src/racket/src/fun.c b/racket/src/racket/src/fun.c index 32c8416e96..1cb69a5a85 100644 --- a/racket/src/racket/src/fun.c +++ b/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)) diff --git a/racket/src/racket/src/module.c b/racket/src/racket/src/module.c index ab43cef9b3..3d67114d2d 100644 --- a/racket/src/racket/src/module.c +++ b/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,7 +4861,7 @@ 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; @@ -4851,6 +4869,16 @@ static Scheme_Object *check_accessible_in_module(Scheme_Module *module, intptr_t 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; } } diff --git a/racket/src/racket/src/optimize.c b/racket/src/racket/src/optimize.c index 59d7e71369..cf1bf5f426 100644 --- a/racket/src/racket/src/optimize.c +++ b/racket/src/racket/src/optimize.c @@ -349,7 +349,7 @@ int scheme_is_functional_nonfailing_primitive(Scheme_Object *rator, int num_args return 0; } -static Scheme_Object *get_struct_proc_shape(Scheme_Object *rator, Optimize_Info *info) +static Scheme_Object *get_struct_proc_shape(Scheme_Object *rator, Optimize_Info *info, int prop_ok) /* Determines whether `rator` is known to be a struct accessor, etc. */ { Scheme_Object *c; @@ -364,7 +364,8 @@ static Scheme_Object *get_struct_proc_shape(Scheme_Object *rator, Optimize_Info c = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos)); if (!c && info->cp->inline_variants) c = scheme_hash_get(info->cp->inline_variants, scheme_make_integer(pos)); - if (c && SAME_TYPE(SCHEME_TYPE(c), scheme_struct_proc_shape_type)) { + if (c && (SAME_TYPE(SCHEME_TYPE(c), scheme_struct_proc_shape_type) + || (prop_ok && SAME_TYPE(SCHEME_TYPE(c), scheme_struct_prop_proc_shape_type)))) { return c; } } @@ -378,13 +379,19 @@ int scheme_is_struct_functional(Scheme_Object *rator, int num_args, Optimize_Inf Scheme_Object *c; if ((vals == 1) || (vals == -1)) { - c = get_struct_proc_shape(rator, info); + c = get_struct_proc_shape(rator, info, 1); if (c) { - int mode = (SCHEME_PROC_SHAPE_MODE(c) & STRUCT_PROC_SHAPE_MASK); - int field_count = (SCHEME_PROC_SHAPE_MODE(c) >> STRUCT_PROC_SHAPE_SHIFT); - if (((num_args == 1) && (mode == STRUCT_PROC_SHAPE_PRED)) - || ((num_args == field_count) && (mode == STRUCT_PROC_SHAPE_CONSTR))) { - return 1; + if (SAME_TYPE(SCHEME_TYPE(c), scheme_struct_proc_shape_type)) { + int mode = (SCHEME_PROC_SHAPE_MODE(c) & STRUCT_PROC_SHAPE_MASK); + int field_count = (SCHEME_PROC_SHAPE_MODE(c) >> STRUCT_PROC_SHAPE_SHIFT); + if (((num_args == 1) && (mode == STRUCT_PROC_SHAPE_PRED)) + || ((num_args == field_count) && (mode == STRUCT_PROC_SHAPE_CONSTR))) { + return 1; + } + } else if (SAME_TYPE(SCHEME_TYPE(c), scheme_struct_prop_proc_shape_type)) { + if ((SCHEME_PROP_PROC_SHAPE_MODE(c) == STRUCT_PROP_PROC_SHAPE_PRED) + && (num_args == 1)) + return 1; } } } @@ -553,8 +560,9 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int flags, note_match(app->num_args, vals, warn_info); } } - - return 0; + + if (!SAME_OBJ(scheme_make_struct_type_proc, app->args[0])) + return 0; } if (vtype == scheme_application2_type) { @@ -579,7 +587,9 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int flags, note_match(1, vals, warn_info); } } - return 0; + + if (!SAME_OBJ(scheme_make_struct_type_property_proc, app->rator)) + return 0; } if (vtype == scheme_application3_type) { @@ -604,7 +614,9 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int flags, note_match(2, vals, warn_info); } } - return 0; + + if (!SAME_OBJ(scheme_make_struct_type_property_proc, app->rator)) + return 0; } /* check for (set! x x) */ @@ -620,10 +632,14 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int flags, } /* check for struct-type declaration: */ - { + if (!(flags & OMITTABLE_IGNORE_MAKE_STRUCT_TYPE)) { Scheme_Object *auto_e; 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 & OMITTABLE_RESOLVED) ? CHECK_STRUCT_TYPE_RESOLVED : 0) + | CHECK_STRUCT_TYPE_ALWAYS_SUCCEED + | CHECK_STRUCT_TYPE_DELAY_AUTO_CHECK), + &auto_e_depth, NULL, NULL, (opt_info ? opt_info->top_level_consts : NULL), ((opt_info && opt_info->cp) ? opt_info->cp->inline_variants : NULL), @@ -635,6 +651,19 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int flags, } } + /* check for struct-type property declaration: */ + if (!(flags & OMITTABLE_IGNORE_MAKE_STRUCT_TYPE)) { + if (scheme_is_simple_make_struct_type_property(o, vals, + (((flags & OMITTABLE_RESOLVED) ? CHECK_STRUCT_TYPE_RESOLVED : 0) + | CHECK_STRUCT_TYPE_ALWAYS_SUCCEED), + NULL, + (opt_info ? opt_info->top_level_consts : NULL), + ((opt_info && opt_info->cp) ? opt_info->cp->inline_variants : NULL), + NULL, NULL, 0, NULL, NULL, + 5)) + return 1; + } + return 0; } @@ -964,7 +993,7 @@ static int is_proc_spec_proc(Scheme_Object *p, int init_field_count) vtype = SCHEME_TYPE(p); - if (vtype == scheme_lambda_type) { + if ((vtype == scheme_lambda_type) || (vtype == scheme_ir_lambda_type)) { if (((Scheme_Lambda *)p)->num_params >= 1) return 1; } @@ -1127,34 +1156,36 @@ static Scheme_Object *skip_clears(Scheme_Object *body) return body; } -static int is_constant_super(Scheme_Object *arg, - Scheme_Hash_Table *top_level_consts, - Scheme_Hash_Table *inline_variants, - Scheme_Hash_Table *top_level_table, - Scheme_Object **runstack, int rs_delta, - Scheme_Object **symbols, Scheme_Hash_Table *symbol_table, - Scheme_Object **_parent_identity) -/* Does `arg` produce another structure type (which can serve as a supertype)? */ +typedef int (*Ok_Value_Callback)(void *data, Scheme_Object *v, int mode); +#define OK_CONSTANT_SHAPE 1 +#define OK_CONSTANT_ENCODED_SHAPE 2 +#define OK_CONSTANT_VALIDATE_SHAPE 3 +#define OK_CONSTANT_VARIANT 4 +#define OK_CONSTANT_VALUE 5 + +static int is_ok_value(Ok_Value_Callback ok_value, void *data, + Scheme_Object *arg, + Scheme_Hash_Table *top_level_consts, + Scheme_Hash_Table *inline_variants, + Scheme_Hash_Table *top_level_table, + Scheme_Object **runstack, int rs_delta, + Scheme_Object **symbols, Scheme_Hash_Table *symbol_table) +/* Does `arg` produce a value that satisfies `ok_value`? */ { int pos; Scheme_Object *v; if (SAME_TYPE(SCHEME_TYPE(arg), scheme_ir_toplevel_type)) { pos = SCHEME_TOPLEVEL_POS(arg); - if (top_level_consts) { + if (top_level_consts || inline_variants) { /* This is optimize mode */ - v = scheme_hash_get(top_level_consts, scheme_make_integer(pos)); + v = NULL; + if (top_level_consts) + v = scheme_hash_get(top_level_consts, scheme_make_integer(pos)); if (!v && inline_variants) v = scheme_hash_get(inline_variants, scheme_make_integer(pos)); - 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 (_parent_identity) - *_parent_identity = SCHEME_PROC_SHAPE_IDENTITY(v); - return field_count + 1; - } - } + if (v) + return ok_value(data, v, OK_CONSTANT_SHAPE); } } else if (SAME_TYPE(SCHEME_TYPE(arg), scheme_toplevel_type)) { pos = SCHEME_TOPLEVEL_POS(arg); @@ -1165,14 +1196,8 @@ static int is_constant_super(Scheme_Object *arg, Scheme_Prefix *toplevels; toplevels = (Scheme_Prefix *)runstack[SCHEME_TOPLEVEL_DEPTH(arg) - rs_delta]; b = (Scheme_Bucket *)toplevels->a[pos]; - if (b->val) { - if (SCHEME_STRUCT_TYPEP(b->val) - && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_CONSISTENT)) { - Scheme_Struct_Type *st = (Scheme_Struct_Type *)b->val; - if (st->num_slots == st->num_islots) - return st->num_slots + 1; - } - } + if (b->val && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_CONSISTENT)) + return ok_value(data, b->val, OK_CONSTANT_VALUE); } if (symbols) { /* This is module-export mode; conceptually, this code belongs in @@ -1181,23 +1206,11 @@ static int is_constant_super(Scheme_Object *arg, name = symbols[pos]; 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); - int field_count = (SCHEME_INT_VAL(v) >> STRUCT_PROC_SHAPE_SHIFT); - if (mode == STRUCT_PROC_SHAPE_STRUCT) - return field_count + 1; - } - } + if (v) + return ok_value(data, v, OK_CONSTANT_VARIANT); } else if (SAME_TYPE(SCHEME_TYPE(name), scheme_module_variable_type)) { - intptr_t k; - if (scheme_decode_struct_shape(((Module_Variable *)name)->shape, &k)) { - if ((k & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_STRUCT) - return (k >> STRUCT_PROC_SHAPE_SHIFT) + 1; - } + if (((Module_Variable *)name)->shape) + return ok_value(data, ((Module_Variable *)name)->shape, OK_CONSTANT_ENCODED_SHAPE); } } if (top_level_table) { @@ -1205,9 +1218,7 @@ static int is_constant_super(Scheme_Object *arg, define_values_validate() */ v = scheme_hash_get(top_level_table, scheme_make_integer(pos)); if (v) { - int k = SCHEME_INT_VAL(v); - if ((k & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_STRUCT) - return (k >> STRUCT_PROC_SHAPE_SHIFT) + 1; + return ok_value(data, v, OK_CONSTANT_VALIDATE_SHAPE); } } } @@ -1215,8 +1226,181 @@ static int is_constant_super(Scheme_Object *arg, return 0; } -Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int resolved, - int must_always_succeed, int check_auto, +static int ok_constant_super_value(void *data, Scheme_Object *v, int mode) +/* Is `v` a structure type (which can serve as a supertype)? */ +{ + Scheme_Object **_parent_identity = (Scheme_Object **)data; + + if (mode == OK_CONSTANT_SHAPE) { + if (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 (_parent_identity) + *_parent_identity = SCHEME_PROC_SHAPE_IDENTITY(v); + return field_count + 1; + } + } + } else if (mode == OK_CONSTANT_ENCODED_SHAPE) { + intptr_t k; + if (scheme_decode_struct_shape(v, &k)) { + if ((k & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_STRUCT) + return (k >> STRUCT_PROC_SHAPE_SHIFT) + 1; + } + } else if (mode == OK_CONSTANT_VALIDATE_SHAPE) { + int k = SCHEME_INT_VAL(v); + if ((k >= 0) + && (k & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_STRUCT) + return (k >> STRUCT_PROC_SHAPE_SHIFT) + 1; + } else if (mode == OK_CONSTANT_VARIANT) { + if (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); + int field_count = (SCHEME_INT_VAL(v) >> STRUCT_PROC_SHAPE_SHIFT); + if (mode == STRUCT_PROC_SHAPE_STRUCT) + return field_count + 1; + } + } + } else if (mode == OK_CONSTANT_VALUE) { + if (SCHEME_STRUCT_TYPEP(v)) { + Scheme_Struct_Type *st = (Scheme_Struct_Type *)v; + if (st->num_slots == st->num_islots) + return st->num_slots + 1; + } + } + + return 0; +} + +static int is_constant_super(Scheme_Object *arg, + Scheme_Hash_Table *top_level_consts, + Scheme_Hash_Table *inline_variants, + Scheme_Hash_Table *top_level_table, + Scheme_Object **runstack, int rs_delta, + Scheme_Object **symbols, Scheme_Hash_Table *symbol_table, + Scheme_Object **_parent_identity) +/* Does `arg` produce another structure type (which can serve as a supertype)? */ +{ + return is_ok_value(ok_constant_super_value, _parent_identity, + arg, + top_level_consts, + inline_variants, top_level_table, + runstack, rs_delta, + symbols, symbol_table); +} + +static int ok_constant_property_with_guard(void *data, Scheme_Object *v, int mode) +{ + intptr_t k = 0; + + if (mode == OK_CONSTANT_SHAPE) { + if (SAME_TYPE(SCHEME_TYPE(v), scheme_struct_prop_proc_shape_type)) { + k = SCHEME_PROC_SHAPE_MODE(v); + } + } else if (mode == OK_CONSTANT_ENCODED_SHAPE) { + if (!scheme_decode_struct_prop_shape(v, &k)) + k = 0; + } else if (mode == OK_CONSTANT_VALIDATE_SHAPE) { + int k = SCHEME_INT_VAL(v); + if (k < 0) + k = -(k+1); + else + k = 0; + } else if (mode == OK_CONSTANT_VARIANT) { + if (SCHEME_VECTORP(v) && (SCHEME_VEC_SIZE(v) == 4)) { + v = SCHEME_VEC_ELS(v)[1]; + if (v && SCHEME_INTP(v)) + k = SCHEME_INT_VAL(v); + } + } else if (mode == OK_CONSTANT_VALUE) { + if (SAME_TYPE(SCHEME_TYPE(v), scheme_struct_property_type)) { + if (!((Scheme_Struct_Property *)v)->guard) + return 1; + } + } + + return (k == STRUCT_PROP_PROC_SHAPE_PROP); +} + +static int is_struct_type_property_without_guard(Scheme_Object *arg, + Scheme_Hash_Table *top_level_consts, + Scheme_Hash_Table *inline_variants, + Scheme_Hash_Table *top_level_table, + Scheme_Object **runstack, int rs_delta, + Scheme_Object **symbols, Scheme_Hash_Table *symbol_table) +/* Does `arg` produce a structure type property that has no guard (so that any value is ok)? */ +{ + return is_ok_value(ok_constant_property_with_guard, NULL, + arg, + top_level_consts, + inline_variants, top_level_table, + runstack, rs_delta, + symbols, symbol_table); +} + +static int is_simple_property_list(Scheme_Object *a, int resolved, + Scheme_Hash_Table *top_level_consts, + Scheme_Hash_Table *inline_variants, + Scheme_Hash_Table *top_level_table, + Scheme_Object **runstack, int rs_delta, + Scheme_Object **symbols, Scheme_Hash_Table *symbol_table) +/* Does `a` produce a property list that always lets `make-struct-type` succeed? */ +{ + Scheme_Object *arg; + int i, count; + + if (SAME_TYPE(SCHEME_TYPE(a), scheme_application_type)) { + if (!SAME_OBJ(((Scheme_App_Rec *)a)->args[0], scheme_list_proc)) + return 0; + count = ((Scheme_App_Rec *)a)->num_args; + } else if (SAME_TYPE(SCHEME_TYPE(a), scheme_application2_type)) { + if (!SAME_OBJ(((Scheme_App2_Rec *)a)->rator, scheme_list_proc)) + return 0; + count = 1; + } else if (SAME_TYPE(SCHEME_TYPE(a), scheme_application3_type)) { + if (!SAME_OBJ(((Scheme_App3_Rec *)a)->rator, scheme_list_proc)) + return 0; + count = 2; + } else + return 0; + + for (i = 0; i < count; i++) { + if (SAME_TYPE(SCHEME_TYPE(a), scheme_application_type)) + arg = ((Scheme_App_Rec *)a)->args[i+1]; + else if (SAME_TYPE(SCHEME_TYPE(a), scheme_application2_type)) + arg = ((Scheme_App2_Rec *)a)->rand; + else { + if (i == 0) + arg = ((Scheme_App3_Rec *)a)->rand1; + else + arg = ((Scheme_App3_Rec *)a)->rand2; + } + + if (SAME_TYPE(SCHEME_TYPE(arg), scheme_application3_type)) { + Scheme_App3_Rec *a3 = (Scheme_App3_Rec *)arg; + + if (!SAME_OBJ(a3->rator, scheme_cons_proc)) + return 0; + if (is_struct_type_property_without_guard(a3->rand1, + top_level_consts, + inline_variants, top_level_table, + runstack, rs_delta, + symbols, symbol_table)) { + if (!scheme_omittable_expr(a3->rand2, 1, 3, (resolved ? OMITTABLE_RESOLVED : 0), NULL, NULL)) + return 0; + } else + return 0; + } else + return 0; + } + + return 1; +} + +Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int flags, GC_CAN_IGNORE int *_auto_e_depth, Simple_Stuct_Type_Info *_stinfo, Scheme_Object **_parent_identity, @@ -1227,13 +1411,18 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int 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 - argument if !check_auto. The resulting constructor must always succeed (i.e., no - guards). The result is the auto-value argument or scheme_true if it's simple, NULL if not. +/* Checks whether it's a `make-struct-type' call --- that, if `flags` includes + `CHECK_STRUCT_TYPE_ALWAYS_SUCCEED`, certainly succeeds (i.e., no exception) --- + pending a check of the auto-value argument if `flags` includes `CHECK_STRUCT_TYPE_DELAY_AUTO_CHECK`. + The expression itself must have no side-effects except for errors (but the possibility + of errors means that the expression is not necessarily omittable). + The resulting *constructor* must always succeed (i.e., no guards). + The result is the auto-value argument or scheme_true if it's simple, NULL if not. The first result of `e` will be a struct type, the second a constructor, and the third a predicate; the rest are selectors and mutators. */ { + int resolved = (flags & CHECK_STRUCT_TYPE_RESOLVED); + if (!fuel) return NULL; if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) { @@ -1263,7 +1452,7 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int && (SCHEME_INT_VAL(app->args[4]) >= 0) && ((app->num_args < 5) /* auto-field value: */ - || !check_auto + || (flags & CHECK_STRUCT_TYPE_DELAY_AUTO_CHECK) || scheme_omittable_expr(app->args[5], 1, 3, (resolved ? OMITTABLE_RESOLVED : 0), NULL, NULL)) && ((app->num_args < 6) /* no properties... */ @@ -1273,8 +1462,14 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int or selectors in a way that matters (although supplying the `prop:chaperone-unsafe-undefined` property can affect the constructor in an optimizer-irrelevant way) */ - || (!must_always_succeed - && scheme_omittable_expr(app->args[6], 1, 4, (resolved ? OMITTABLE_RESOLVED : 0), NULL, NULL))) + || (!(flags & CHECK_STRUCT_TYPE_ALWAYS_SUCCEED) + && scheme_omittable_expr(app->args[6], 1, 4, (resolved ? OMITTABLE_RESOLVED : 0), NULL, NULL)) + || ((flags & CHECK_STRUCT_TYPE_ALWAYS_SUCCEED) + && is_simple_property_list(app->args[6], resolved, + top_level_consts, inline_variants, + top_level_table, + runstack, rs_delta, + symbols, symbol_table))) && ((app->num_args < 7) /* inspector: */ || SCHEME_FALSEP(app->args[7]) @@ -1333,8 +1528,7 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int Scheme_Object *auto_e; Simple_Stuct_Type_Info stinfo; if (!_stinfo) _stinfo = &stinfo; - auto_e = scheme_is_simple_make_struct_type(lv->value, 5, resolved, - must_always_succeed, check_auto, + auto_e = scheme_is_simple_make_struct_type(lv->value, 5, flags, _auto_e_depth, _stinfo, _parent_identity, top_level_consts, inline_variants, top_level_table, runstack, rs_delta, @@ -1366,8 +1560,7 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int Scheme_Object *auto_e; Simple_Stuct_Type_Info stinfo; if (!_stinfo) _stinfo = &stinfo; - auto_e = scheme_is_simple_make_struct_type(e2, 5, resolved, - must_always_succeed, check_auto, + auto_e = scheme_is_simple_make_struct_type(e2, 5, flags, _auto_e_depth, _stinfo, _parent_identity, top_level_consts, inline_variants, top_level_table, runstack, rs_delta + lvd->count, @@ -1391,6 +1584,48 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int return NULL; } + +int scheme_is_simple_make_struct_type_property(Scheme_Object *e, int vals, int flags, + int *_has_guard, + Scheme_Hash_Table *top_level_consts, + Scheme_Hash_Table *inline_variants, + Scheme_Hash_Table *top_level_table, + Scheme_Object **runstack, int rs_delta, + Scheme_Object **symbols, Scheme_Hash_Table *symbol_table, + int fuel) +/* Reports whether `app` is a call to `make-struct-type-property` to + produce a propert with no guard. */ +{ + int resolved = (flags & CHECK_STRUCT_TYPE_RESOLVED); + + if ((vals != 3) && (vals >= 0)) return 0; + + if (SAME_TYPE(SCHEME_TYPE(e), scheme_application2_type)) { + Scheme_App2_Rec *app = (Scheme_App2_Rec *)e; + if (SAME_OBJ(app->rator, scheme_make_struct_type_property_proc)) { + if (SCHEME_SYMBOLP(app->rand)) { + if (_has_guard) *_has_guard = 0; + return 1; + } + } + } + + if (SAME_TYPE(SCHEME_TYPE(e), scheme_application3_type)) { + Scheme_App3_Rec *app = (Scheme_App3_Rec *)e; + if (SAME_OBJ(app->rator, scheme_make_struct_type_property_proc)) { + if (SCHEME_SYMBOLP(app->rand1) + && (!(flags & CHECK_STRUCT_TYPE_ALWAYS_SUCCEED) + || SCHEME_LAMBDAP(app->rand2)) + && (scheme_omittable_expr(app->rator, 1, 4, (resolved ? OMITTABLE_RESOLVED : 0), NULL, NULL))) { + if (_has_guard) *_has_guard = 1; + return 1; + } + } + } + + return 0; +} + /*========================================================================*/ /* more utils */ /*========================================================================*/ @@ -1436,6 +1671,33 @@ Scheme_Object *scheme_make_struct_proc_shape(intptr_t k, Scheme_Object *identity return ps; } +intptr_t scheme_get_struct_property_proc_shape(int k, int has_guard) +{ + switch (k) { + case 0: + if (has_guard) + return STRUCT_PROP_PROC_SHAPE_GUARDED_PROP; + else + return STRUCT_PROP_PROC_SHAPE_PROP; + case 1: + return STRUCT_PROP_PROC_SHAPE_PRED; + case 2: + default: + return STRUCT_PROP_PROC_SHAPE_GETTER; + } +} + +Scheme_Object *scheme_make_struct_property_proc_shape(intptr_t k) +{ + Scheme_Object *ps; + + ps = scheme_alloc_small_object(); + ps->type = scheme_struct_prop_proc_shape_type; + SCHEME_PROP_PROC_SHAPE_MODE(ps) = k; + + 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 @@ -3831,7 +4093,7 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz if (SAME_OBJ(scheme_struct_type_p_proc, rator)) { Scheme_Object *c; - c = get_struct_proc_shape(rand, info); + c = get_struct_proc_shape(rand, info, 0); if (c && ((SCHEME_PROC_SHAPE_MODE(c) & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_STRUCT)) { info->preserves_marks = 1; @@ -3935,7 +4197,7 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz } /* Using a struct getter or predicate? */ - alt = get_struct_proc_shape(rator, info); + alt = get_struct_proc_shape(rator, info, 0); if (alt) { int mode = (SCHEME_PROC_SHAPE_MODE(alt) & STRUCT_PROC_SHAPE_MASK); @@ -4987,7 +5249,7 @@ static void add_types_for_t_branch(Scheme_Object *t, Optimize_Info *info, int fu if (SAME_TYPE(SCHEME_TYPE(app->rand), scheme_ir_local_type)) { Scheme_Object *shape; - shape = get_struct_proc_shape(app->rator, info); + shape = get_struct_proc_shape(app->rator, info, 0); if (shape && ((SCHEME_PROC_SHAPE_MODE(shape) & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_PRED) && SCHEME_PAIRP(SCHEME_PROC_SHAPE_IDENTITY(shape))) { @@ -7914,6 +8176,23 @@ int split_define_values(Scheme_Object *e, int n, Scheme_Object *vars, Scheme_Obj return 0; } +static Scheme_Hash_Table *set_as_fixed(Scheme_Hash_Table *fixed_table, Optimize_Info *info, int pos) +{ + if (!fixed_table) { + fixed_table = scheme_make_hash_table(SCHEME_hash_ptr); + if (!info->top_level_consts) { + Scheme_Hash_Table *consts; + consts = scheme_make_hash_table(SCHEME_hash_ptr); + info->top_level_consts = consts; + } + scheme_hash_set(info->top_level_consts, scheme_false, (Scheme_Object *)fixed_table); + } + + scheme_hash_set(fixed_table, scheme_make_integer(pos), scheme_true); + + return fixed_table; +} + static Scheme_Object * module_optimize(Scheme_Object *data, Optimize_Info *info, int context) { @@ -7951,7 +8230,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) /* Use `limited_info` for optimization decisions that need to be rediscovered by the validator. The validator knows shape - information for imported variables, and it know about structure + information for imported variables, and it knows about structure bindings for later forms. */ limited_info = MALLOC_ONE_RT(Optimize_Info); #ifdef MZTAG_REQUIRED @@ -8076,8 +8355,8 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) /* If this expression/definition can't have any side effect (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; + if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { + int n, cnst = 0, sproc = 0, sprop = 0, has_guard = 0; Scheme_Object *sstruct = NULL, *parent_identity = NULL; Simple_Stuct_Type_Info stinfo; @@ -8088,8 +8367,11 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) cont = scheme_omittable_expr(e, n, -1, /* ignore APPN_FLAG_OMITTABLE, because the validator won't be able to reconstruct it - in general */ - OMITTABLE_IGNORE_APPN_OMIT, + in general; also, don't recognize struct-type + functions, since they weren't recognized + as immediate calls */ + (OMITTABLE_IGNORE_APPN_OMIT + | OMITTABLE_IGNORE_MAKE_STRUCT_TYPE), /* similarly, use `limited_info` instead of `info' here, because the decision of omittable should not depend on @@ -8105,7 +8387,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) cnst = 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, NULL, &stinfo, &parent_identity, info->top_level_consts, info->cp->inline_variants, @@ -8114,9 +8396,24 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) 5)) { sstruct = scheme_make_pair(sstruct, parent_identity); cnst = 1; + } else if (scheme_is_simple_make_struct_type_property(e, n, 0, + &has_guard, + info->top_level_consts, + info->cp->inline_variants, + NULL, NULL, 0, NULL, NULL, + 5)) { + sprop = 1; + cnst = 1; } else sstruct = NULL; + if ((sstruct || sprop) && !cont) { + /* Since the `make-struct-type` or `make-struct-tye-property` form is immediate + enough that the validator can see it, re-check whether we can continue + a group of simultaneously defined variables. */ + cont = scheme_omittable_expr(e, n, 5, OMITTABLE_IGNORE_APPN_OMIT, limited_info, NULL); + } + if (cnst) { Scheme_Toplevel *tl; int i; @@ -8130,6 +8427,8 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) if (sstruct) { e2 = scheme_make_struct_proc_shape(scheme_get_struct_proc_shape(i, &stinfo), sstruct); + } else if (sprop) { + e2 = scheme_make_struct_property_proc_shape(scheme_get_struct_property_proc_shape(i, has_guard)); } else if (sproc) { e2 = scheme_make_noninline_proc(e); } else if (SCHEME_LAMBDAP(e)) { @@ -8159,7 +8458,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) } scheme_hash_set(consts, scheme_make_integer(pos), e2); - if (sstruct) { + if (sstruct || sprop) { /* include in `limited_info` */ Scheme_Hash_Table *limited_consts = limited_info->top_level_consts; if (!limited_consts) { @@ -8179,23 +8478,15 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) } } else { /* At least mark it as fixed */ - if (!fixed_table) { - fixed_table = scheme_make_hash_table(SCHEME_hash_ptr); - if (!info->top_level_consts) { - consts = scheme_make_hash_table(SCHEME_hash_ptr); - info->top_level_consts = consts; - consts = NULL; - } - scheme_hash_set(info->top_level_consts, scheme_false, (Scheme_Object *)fixed_table); - } - scheme_hash_set(fixed_table, scheme_make_integer(tl->position), scheme_true); + fixed_table = set_as_fixed(fixed_table, info, tl->position); } } } } else { /* The binding is not inlinable/propagatable, but unless it's set!ed, it is constant after evaluating the definition. We - map the top-level position to indicate constantness. */ + map the top-level position to indicate constantness --- immediately + if `cont`, and later if not. */ Scheme_Object *l, *a; int pos; @@ -8206,7 +8497,10 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) if (!(SCHEME_TOPLEVEL_FLAGS(a) & SCHEME_TOPLEVEL_MUTATED)) { pos = SCHEME_TOPLEVEL_POS(a); - next_pos_ready = pos; + if (cont) + fixed_table = set_as_fixed(fixed_table, info, pos); + else + next_pos_ready = pos; } } } @@ -8321,16 +8615,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) } if (next_pos_ready > -1) { - if (!fixed_table) { - fixed_table = scheme_make_hash_table(SCHEME_hash_ptr); - if (!info->top_level_consts) { - consts = scheme_make_hash_table(SCHEME_hash_ptr); - info->top_level_consts = consts; - consts = NULL; - } - scheme_hash_set(info->top_level_consts, scheme_false, (Scheme_Object *)fixed_table); - } - scheme_hash_set(fixed_table, scheme_make_integer(next_pos_ready), scheme_true); + fixed_table = set_as_fixed(fixed_table, info, next_pos_ready); next_pos_ready = -1; } } diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index 6241cbfb1e..ff9a115d8c 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -538,6 +538,7 @@ extern Scheme_Object *scheme_call_with_immed_mark_proc; extern Scheme_Object *scheme_make_struct_type_proc; extern Scheme_Object *scheme_make_struct_field_accessor_proc; extern Scheme_Object *scheme_make_struct_field_mutator_proc; +extern Scheme_Object *scheme_make_struct_type_property_proc; extern Scheme_Object *scheme_struct_to_vector_proc; extern Scheme_Object *scheme_struct_type_p_proc; extern Scheme_Object *scheme_current_inspector_proc; @@ -3480,6 +3481,7 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int flags, #define OMITTABLE_KEEP_VARS 0x2 #define OMITTABLE_KEEP_MUTABLE_VARS 0x4 #define OMITTABLE_IGNORE_APPN_OMIT 0x8 +#define OMITTABLE_IGNORE_MAKE_STRUCT_TYPE 0x10 int scheme_might_invoke_call_cc(Scheme_Object *value); int scheme_is_liftable(Scheme_Object *o, Scheme_Hash_Tree *exclude_vars, int fuel, int as_rator, int or_escape); @@ -3495,9 +3497,8 @@ typedef struct { 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, +Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *app, int vals, int flags, + int *_auto_e_depth, Simple_Stuct_Type_Info *_stinfo, Scheme_Object **_parent_identity, Scheme_Hash_Table *top_level_consts, @@ -3507,6 +3508,17 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *app, int vals, i Scheme_Object **symbols, Scheme_Hash_Table *symbol_table, Scheme_Object **_name, int fuel); +int scheme_is_simple_make_struct_type_property(Scheme_Object *app, int vals, int flags, + int *_has_guard, + Scheme_Hash_Table *top_level_consts, + Scheme_Hash_Table *inline_variants, + Scheme_Hash_Table *top_level_table, + Scheme_Object **runstack, int rs_delta, + Scheme_Object **symbols, Scheme_Hash_Table *symbol_table, + int fuel); +#define CHECK_STRUCT_TYPE_RESOLVED 0x1 +#define CHECK_STRUCT_TYPE_ALWAYS_SUCCEED 0x2 +#define CHECK_STRUCT_TYPE_DELAY_AUTO_CHECK 0x4 Scheme_Object *scheme_intern_struct_proc_shape(int shape); intptr_t scheme_get_struct_proc_shape(int k, Simple_Stuct_Type_Info *sinfo); @@ -3528,9 +3540,20 @@ typedef struct 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_intern_struct_prop_proc_shape(int shape); +intptr_t scheme_get_struct_property_proc_shape(int k, int has_guard); +Scheme_Object *scheme_make_struct_property_proc_shape(intptr_t k); +#define STRUCT_PROP_PROC_SHAPE_PROP 0 +#define STRUCT_PROP_PROC_SHAPE_GUARDED_PROP 1 +#define STRUCT_PROP_PROC_SHAPE_PRED 2 +#define STRUCT_PROP_PROC_SHAPE_GETTER 3 +#define SCHEME_PROP_PROC_SHAPE_MODE(obj) ((Scheme_Small_Object *)obj)->u.int_val + 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_decode_struct_shape(Scheme_Object *shape, intptr_t *_v); +int scheme_check_structure_property_shape(Scheme_Object *e, Scheme_Object *expected); +int scheme_decode_struct_prop_shape(Scheme_Object *shape, intptr_t *_v); int scheme_closure_preserves_marks(Scheme_Object *p); int scheme_native_closure_preserves_marks(Scheme_Object *p); int scheme_native_closure_is_single_result(Scheme_Object *rator); diff --git a/racket/src/racket/src/struct.c b/racket/src/racket/src/struct.c index 8346157716..086f6b9d48 100644 --- a/racket/src/racket/src/struct.c +++ b/racket/src/racket/src/struct.c @@ -39,6 +39,7 @@ READ_ONLY Scheme_Object *scheme_impersonator_of_property; READ_ONLY Scheme_Object *scheme_make_struct_type_proc; READ_ONLY Scheme_Object *scheme_make_struct_field_accessor_proc; READ_ONLY Scheme_Object *scheme_make_struct_field_mutator_proc; +READ_ONLY Scheme_Object *scheme_make_struct_type_property_proc; READ_ONLY Scheme_Object *scheme_struct_type_p_proc; READ_ONLY Scheme_Object *scheme_current_inspector_proc; READ_ONLY Scheme_Object *scheme_make_inspector_proc; @@ -557,11 +558,13 @@ scheme_init_struct (Scheme_Env *env) scheme_make_struct_type_proc, env); - scheme_add_global_constant("make-struct-type-property", - scheme_make_prim_w_arity2(make_struct_type_property, - "make-struct-type-property", - 1, 4, - 3, 3), + REGISTER_SO(scheme_make_struct_type_property_proc); + scheme_make_struct_type_property_proc = scheme_make_prim_w_arity2(make_struct_type_property, + "make-struct-type-property", + 1, 4, + 3, 3); + scheme_add_global_constant("make-struct-type-property", + scheme_make_struct_type_property_proc, env); REGISTER_SO(scheme_make_struct_field_accessor_proc); @@ -3555,7 +3558,8 @@ int scheme_decode_struct_shape(Scheme_Object *expected, intptr_t *_v) if (!expected || !SCHEME_SYMBOLP(expected)) return 0; - if (SCHEME_SYM_VAL(expected)[0] != 's') + if ((SCHEME_SYM_VAL(expected)[0] != 's') + || (SCHEME_SYM_LEN(expected) < 6)) return 0; for (i = 6, v = 0; SCHEME_SYM_VAL(expected)[i]; i++) { @@ -3611,6 +3615,53 @@ int scheme_check_structure_shape(Scheme_Object *e, Scheme_Object *expected) return 0; } +int scheme_decode_struct_prop_shape(Scheme_Object *expected, intptr_t *_v) +{ + intptr_t v; + int i; + + if (!expected || !SCHEME_SYMBOLP(expected)) + return 0; + + if ((SCHEME_SYM_VAL(expected)[0] != 'p') + || (SCHEME_SYM_LEN(expected) < 4)) + return 0; + + for (i = 4, v = 0; SCHEME_SYM_VAL(expected)[i]; i++) { + v = (v * 10) + (SCHEME_SYM_VAL(expected)[i] - '0'); + } + + *_v = v; + + return 1; +} + +int scheme_check_structure_property_shape(Scheme_Object *e, Scheme_Object *expected) +{ + intptr_t _v, v; + int i; + + if (!scheme_decode_struct_prop_shape(expected, &_v)) + return 0; + v = _v; + + if (SAME_TYPE(SCHEME_TYPE(e), scheme_struct_property_type)) { + if (((Scheme_Struct_Property *)e)->guard) + return (v == STRUCT_PROP_PROC_SHAPE_GUARDED_PROP); + return ((v == STRUCT_PROP_PROC_SHAPE_PROP) + || (v == STRUCT_PROP_PROC_SHAPE_GUARDED_PROP)); + } else if (!SCHEME_PRIMP(e)) + return 0; + + i = (((Scheme_Primitive_Proc *)e)->pp.flags & SCHEME_PRIM_OTHER_TYPE_MASK); + if (i == SCHEME_PRIM_STRUCT_TYPE_STRUCT_PROP_PRED) + return (v == STRUCT_PROP_PROC_SHAPE_PRED); + else if (i == SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER) + return (v == STRUCT_PROP_PROC_SHAPE_GETTER); + + return 0; +} + static Scheme_Object *make_struct_field_xxor(const char *who, int getter, int argc, Scheme_Object *argv[]) { diff --git a/racket/src/racket/src/stypes.h b/racket/src/racket/src/stypes.h index f5b9d7030d..89218bb6ce 100644 --- a/racket/src/racket/src/stypes.h +++ b/racket/src/racket/src/stypes.h @@ -224,94 +224,95 @@ enum { scheme_port_closed_evt_type, /* 193 */ scheme_proc_shape_type, /* 194 */ scheme_struct_proc_shape_type, /* 195 */ - scheme_phantom_bytes_type, /* 196 */ - scheme_environment_variables_type, /* 197 */ - scheme_filesystem_change_evt_type, /* 198 */ - scheme_ctype_type, /* 199 */ - scheme_plumber_type, /* 200 */ - scheme_plumber_handle_type, /* 201 */ - scheme_deferred_expr_type, /* 202 */ - scheme_will_be_lambda_type, /* 203 */ - scheme_syntax_property_preserve_type, /* 204 */ + scheme_struct_prop_proc_shape_type, /* 196 */ + scheme_phantom_bytes_type, /* 197 */ + scheme_environment_variables_type, /* 198 */ + scheme_filesystem_change_evt_type, /* 199 */ + scheme_ctype_type, /* 200 */ + scheme_plumber_type, /* 201 */ + scheme_plumber_handle_type, /* 202 */ + scheme_deferred_expr_type, /* 203 */ + scheme_will_be_lambda_type, /* 204 */ + scheme_syntax_property_preserve_type, /* 205 */ #ifdef MZTAG_REQUIRED - _scheme_last_normal_type_, /* 205 */ + _scheme_last_normal_type_, /* 206 */ /* The remaining tags exist for GC tracing (in non-conservative mode), but they are not needed for run-time tag tests */ - scheme_rt_weak_array, /* 206 */ + scheme_rt_weak_array, /* 207 */ - scheme_rt_comp_env, /* 207 */ - scheme_rt_constant_binding, /* 208 */ - scheme_rt_resolve_info, /* 209 */ - scheme_rt_unresolve_info, /* 210 */ - scheme_rt_optimize_info, /* 211 */ - scheme_rt_cont_mark, /* 212 */ - scheme_rt_saved_stack, /* 213 */ - scheme_rt_reply_item, /* 214 */ - scheme_rt_ir_lambda_info, /* 215 */ - scheme_rt_overflow, /* 216 */ - scheme_rt_overflow_jmp, /* 217 */ - scheme_rt_meta_cont, /* 218 */ - scheme_rt_dyn_wind_cell, /* 219 */ - scheme_rt_dyn_wind_info, /* 220 */ - scheme_rt_dyn_wind, /* 221 */ - scheme_rt_dup_check, /* 222 */ - scheme_rt_thread_memory, /* 223 */ - scheme_rt_input_file, /* 224 */ - scheme_rt_input_fd, /* 225 */ - scheme_rt_oskit_console_input, /* 226 */ - scheme_rt_tested_input_file, /* 227 */ - scheme_rt_tested_output_file, /* 228 */ - scheme_rt_indexed_string, /* 229 */ - scheme_rt_output_file, /* 230 */ - scheme_rt_load_handler_data, /* 231 */ - scheme_rt_pipe, /* 232 */ - scheme_rt_beos_process, /* 233 */ - scheme_rt_system_child, /* 234 */ - scheme_rt_tcp, /* 235 */ - scheme_rt_write_data, /* 236 */ - scheme_rt_tcp_select_info, /* 237 */ - scheme_rt_param_data, /* 238 */ - scheme_rt_will, /* 239 */ - scheme_rt_linker_name, /* 240 */ - scheme_rt_param_map, /* 241 */ - scheme_rt_finalization, /* 242 */ - scheme_rt_finalizations, /* 243 */ - scheme_rt_cpp_object, /* 244 */ - scheme_rt_cpp_array_object, /* 245 */ - scheme_rt_stack_object, /* 246 */ - scheme_rt_preallocated_object, /* 247 */ - scheme_thread_hop_type, /* 248 */ - scheme_rt_srcloc, /* 249 */ - scheme_rt_evt, /* 250 */ - scheme_rt_syncing, /* 251 */ - scheme_rt_comp_prefix, /* 252 */ - scheme_rt_user_input, /* 253 */ - scheme_rt_user_output, /* 254 */ - scheme_rt_compact_port, /* 255 */ - scheme_rt_read_special_dw, /* 256 */ - scheme_rt_regwork, /* 257 */ - scheme_rt_rx_lazy_string, /* 258 */ - scheme_rt_buf_holder, /* 259 */ - scheme_rt_parameterization, /* 260 */ - scheme_rt_print_params, /* 261 */ - scheme_rt_read_params, /* 262 */ - scheme_rt_native_code, /* 263 */ - scheme_rt_native_code_plus_case, /* 264 */ - scheme_rt_jitter_data, /* 265 */ - scheme_rt_module_exports, /* 266 */ - scheme_rt_delay_load_info, /* 267 */ - scheme_rt_marshal_info, /* 268 */ - scheme_rt_unmarshal_info, /* 269 */ - scheme_rt_runstack, /* 270 */ - scheme_rt_sfs_info, /* 271 */ - scheme_rt_validate_clearing, /* 272 */ - scheme_rt_lightweight_cont, /* 273 */ - scheme_rt_export_info, /* 274 */ - scheme_rt_cont_jmp, /* 275 */ - scheme_rt_letrec_check_frame, /* 276 */ + scheme_rt_comp_env, /* 208 */ + scheme_rt_constant_binding, /* 209 */ + scheme_rt_resolve_info, /* 210 */ + scheme_rt_unresolve_info, /* 211 */ + scheme_rt_optimize_info, /* 212 */ + scheme_rt_cont_mark, /* 213 */ + scheme_rt_saved_stack, /* 214 */ + scheme_rt_reply_item, /* 215 */ + scheme_rt_ir_lambda_info, /* 216 */ + scheme_rt_overflow, /* 217 */ + scheme_rt_overflow_jmp, /* 218 */ + scheme_rt_meta_cont, /* 219 */ + scheme_rt_dyn_wind_cell, /* 220 */ + scheme_rt_dyn_wind_info, /* 221 */ + scheme_rt_dyn_wind, /* 222 */ + scheme_rt_dup_check, /* 223 */ + scheme_rt_thread_memory, /* 224 */ + scheme_rt_input_file, /* 225 */ + scheme_rt_input_fd, /* 226 */ + scheme_rt_oskit_console_input, /* 227 */ + scheme_rt_tested_input_file, /* 228 */ + scheme_rt_tested_output_file, /* 229 */ + scheme_rt_indexed_string, /* 230 */ + scheme_rt_output_file, /* 231 */ + scheme_rt_load_handler_data, /* 232 */ + scheme_rt_pipe, /* 233 */ + scheme_rt_beos_process, /* 234 */ + scheme_rt_system_child, /* 235 */ + scheme_rt_tcp, /* 236 */ + scheme_rt_write_data, /* 237 */ + scheme_rt_tcp_select_info, /* 238 */ + scheme_rt_param_data, /* 239 */ + scheme_rt_will, /* 240 */ + scheme_rt_linker_name, /* 241 */ + scheme_rt_param_map, /* 242 */ + scheme_rt_finalization, /* 243 */ + scheme_rt_finalizations, /* 244 */ + scheme_rt_cpp_object, /* 245 */ + scheme_rt_cpp_array_object, /* 246 */ + scheme_rt_stack_object, /* 247 */ + scheme_rt_preallocated_object, /* 248 */ + scheme_thread_hop_type, /* 249 */ + scheme_rt_srcloc, /* 250 */ + scheme_rt_evt, /* 251 */ + scheme_rt_syncing, /* 252 */ + scheme_rt_comp_prefix, /* 253 */ + scheme_rt_user_input, /* 254 */ + scheme_rt_user_output, /* 255 */ + scheme_rt_compact_port, /* 256 */ + scheme_rt_read_special_dw, /* 257 */ + scheme_rt_regwork, /* 258 */ + scheme_rt_rx_lazy_string, /* 259 */ + scheme_rt_buf_holder, /* 260 */ + scheme_rt_parameterization, /* 261 */ + scheme_rt_print_params, /* 262 */ + scheme_rt_read_params, /* 263 */ + scheme_rt_native_code, /* 264 */ + scheme_rt_native_code_plus_case, /* 265 */ + scheme_rt_jitter_data, /* 266 */ + scheme_rt_module_exports, /* 267 */ + scheme_rt_delay_load_info, /* 268 */ + scheme_rt_marshal_info, /* 269 */ + scheme_rt_unmarshal_info, /* 270 */ + scheme_rt_runstack, /* 271 */ + scheme_rt_sfs_info, /* 272 */ + scheme_rt_validate_clearing, /* 273 */ + scheme_rt_lightweight_cont, /* 274 */ + scheme_rt_export_info, /* 275 */ + scheme_rt_cont_jmp, /* 276 */ + scheme_rt_letrec_check_frame, /* 277 */ #endif _scheme_last_type_ diff --git a/racket/src/racket/src/type.c b/racket/src/racket/src/type.c index 190e0575e7..57409066af 100644 --- a/racket/src/racket/src/type.c +++ b/racket/src/racket/src/type.c @@ -740,6 +740,7 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_proc_shape_type, small_atomic_obj); GC_REG_TRAV(scheme_struct_proc_shape_type, struct_proc_shape); + GC_REG_TRAV(scheme_struct_prop_proc_shape_type, small_atomic_obj); GC_REG_TRAV(scheme_environment_variables_type, small_object); GC_REG_TRAV(scheme_syntax_property_preserve_type, small_object); diff --git a/racket/src/racket/src/validate.c b/racket/src/racket/src/validate.c index 84d70f4ab4..d749ed6790 100644 --- a/racket/src/racket/src/validate.c +++ b/racket/src/racket/src/validate.c @@ -123,13 +123,19 @@ static void noclear_stack_push(struct Validate_Clearing *vc, int pos) } -static void add_struct_mapping(Scheme_Hash_Table **_st_ht, int pos, int shape) +static void add_struct_mapping(Scheme_Hash_Table **_st_ht, int pos, int shape, int for_property) { if (!*_st_ht) { Scheme_Hash_Table *ht; ht = scheme_make_hash_table_eqv(); *_st_ht = ht; } + + if (for_property) { + /* negative value is for a structure type property: */ + shape = -(shape+1); + } + scheme_hash_set(*_st_ht, scheme_make_integer(pos), scheme_make_integer(shape)); @@ -185,7 +191,9 @@ void scheme_validate_code(Mz_CPort *port, Scheme_Object *code, intptr_t k; tl_state[i] = SCHEME_TOPLEVEL_CONST; if (scheme_decode_struct_shape(((Module_Variable *)toplevels[i])->shape, &k)) - add_struct_mapping(_st_ht, i, k); + add_struct_mapping(_st_ht, i, k, 0); + else if (scheme_decode_struct_prop_shape(((Module_Variable *)toplevels[i])->shape, &k)) + add_struct_mapping(_st_ht, i, k, 1); } else if (mv_flags & SCHEME_MODVAR_FIXED) tl_state[i] = SCHEME_TOPLEVEL_FIXED; else @@ -295,7 +303,7 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port, Scheme_Hash_Tree *procs, Scheme_Hash_Table **_st_ht) { - int i, size, flags, result, is_struct; + int i, size, flags, result, is_struct, is_struct_prop, has_guard; Simple_Stuct_Type_Info stinfo; Scheme_Object *val, *only_var; @@ -399,7 +407,8 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port, only_var = NULL; } - if (scheme_is_simple_make_struct_type(val, size-1, 1, 0, 1, NULL, + if (scheme_is_simple_make_struct_type(val, size-1, CHECK_STRUCT_TYPE_RESOLVED, + NULL, &stinfo, NULL, NULL, NULL, (_st_ht ? *_st_ht : NULL), NULL, 0, NULL, NULL, NULL, 5)) { @@ -411,6 +420,16 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port, is_struct = 0; } + has_guard = 0; + if (scheme_is_simple_make_struct_type_property(val, size-1, CHECK_STRUCT_TYPE_RESOLVED, + &has_guard, + NULL, NULL, (_st_ht ? *_st_ht : NULL), + NULL, 0, NULL, NULL, 5)) { + is_struct_prop = 1; + } else { + is_struct_prop = 0; + } + result = validate_expr(port, val, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, @@ -430,7 +449,22 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port, || (stinfo.field_count == stinfo.init_field_count)) add_struct_mapping(_st_ht, SCHEME_TOPLEVEL_POS(SCHEME_VEC_ELS(data)[i]), - scheme_get_struct_proc_shape(i-1, &stinfo)); + scheme_get_struct_proc_shape(i-1, &stinfo), + 0); + } + } + /* In any case, treat the bindings as constant */ + result = 2; + } else if (is_struct_prop) { + if (_st_ht) { + /* Record `prop:' binding as constant across invocations, + so that it can be recognized for struct declarations, + and so on: */ + for (i = 1; i < size; i++) { + add_struct_mapping(_st_ht, + SCHEME_TOPLEVEL_POS(SCHEME_VEC_ELS(data)[i]), + scheme_get_struct_property_proc_shape(i-1, has_guard), + 1); } } /* In any case, treat the bindings as constant */ @@ -1385,8 +1419,10 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, } else { /* check expectation */ if (((tl_state[p] & SCHEME_TOPLEVEL_FLAGS_MASK) < flags) - || ((tl_state[p] >> 2) > tl_timestamp)) + || ((tl_state[p] >> 2) > tl_timestamp)) { + printf("?? %d\n", p); scheme_ill_formed_code(port); + } } }