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

improve structure-type property handling

Browse Source 
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.
This commit is contained in:
Matthew Flatt 2016-08-07 09:09:25 -06:00
parent 7bcc9afd4c
commit ad230d2ca0
15 changed files with 779 additions and 217 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
pkgs/racket-doc/scribblings/raco/zo-struct.scrbl
View File

@ -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) ()]
)]{

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

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

12
pkgs/zo-lib/compiler/zo-marshal.rkt
View File

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

7
pkgs/zo-lib/compiler/zo-parse.rkt
View File

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

3
pkgs/zo-lib/compiler/zo-structs.rkt
View File

@ -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:

12
racket/src/racket/src/compenv.c
View File

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

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

@ -2031,11 +2031,17 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro,
if (dm_env)
is_st = 0;
else
is_st = !!scheme_is_simple_make_struct_type(vals_expr, g, 1, 0, 1,
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);
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 = 0;
for (i = 0; i < g; i++) {
var = SCHEME_VEC_ELS(vec)[i+delta];

9
racket/src/racket/src/fun.c
View File

@ -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') {
&& 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))

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

@ -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;
}
}

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

@ -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,14 +379,20 @@ 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) {
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;
}
}
}
@ -554,6 +561,7 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int flags,
}
}
if (!SAME_OBJ(scheme_make_struct_type_proc, app->args[0]))
return 0;
}
@ -579,6 +587,8 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int flags,
note_match(1, vals, warn_info);
}
}
if (!SAME_OBJ(scheme_make_struct_type_property_proc, app->rator))
return 0;
}
@ -604,6 +614,8 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int flags,
note_match(2, vals, warn_info);
}
}
if (!SAME_OBJ(scheme_make_struct_type_property_proc, app->rator))
return 0;
}
@ -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,
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,
Scheme_Object **_parent_identity)
/* Does `arg` produce another structure type (which can serve as a supertype)? */
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 = 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,7 +1206,54 @@ 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 (v)
return ok_value(data, v, OK_CONSTANT_VARIANT);
} else if (SAME_TYPE(SCHEME_TYPE(name), scheme_module_variable_type)) {
if (((Module_Variable *)name)->shape)
return ok_value(data, ((Module_Variable *)name)->shape, OK_CONSTANT_ENCODED_SHAPE);
}
}
if (top_level_table) {
/* This is validate mode; conceptually, this code belongs in
define_values_validate() */
v = scheme_hash_get(top_level_table, scheme_make_integer(pos));
if (v) {
return ok_value(data, v, OK_CONSTANT_VALIDATE_SHAPE);
}
}
}
return 0;
}
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];
@ -1192,31 +1264,143 @@ static int is_constant_super(Scheme_Object *arg,
return field_count + 1;
}
}
} 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 (top_level_table) {
/* This is validate mode; conceptually, this code belongs in
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;
}
} 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;
}
Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int resolved,
int must_always_succeed, int check_auto,
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
@ -8077,7 +8356,7 @@ 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;
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,6 +8497,9 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
if (!(SCHEME_TOPLEVEL_FLAGS(a) & SCHEME_TOPLEVEL_MUTATED)) {
pos = SCHEME_TOPLEVEL_POS(a);
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;
}
}

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

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

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

@ -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,
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),
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[])
{

163
racket/src/racket/src/stypes.h
View File

@ -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_

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

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

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

@ -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,10 +1419,12 @@ 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);
}
}
}
if ((proc_with_refs_ok != 1)
&& !argument_to_arity_error(app_rator, proc_with_refs_ok)) {