fix JIT bug related to bad struct-field mutators

We can't disallow the creation of bad mutators without breaking
old code, but we can prevent the JIT from treating them like
good ones.

Closes PR 13062
This commit is contained in:
Matthew Flatt 2012-08-24 15:40:44 -06:00
parent 23722e64c2
commit bd8e1e8b1f
4 changed files with 34 additions and 3 deletions

View File

@ -1071,6 +1071,31 @@
(test #f prefab-key? '#(apple))
(test #t prefab-key? '(apple 4))
;; ----------------------------------------
;; We can make a bogus mutator, but we can't apply it:
(let ()
;; Test based on code from dmarshall:
(define-values (struct:thing make-thing thing? thing-ref thing-set!)
(make-struct-type
'thing #f 1 0
#f ; auto val
(list) ; property list
#f ; inspector
#f ; proc-spec
(list 0))) ; immutables
(define thing.id (make-struct-field-accessor thing-ref 0))
(define thing.id! (make-struct-field-mutator thing-set! 0))
(test #t struct-mutator-procedure? thing.id!)
(err/rt-test (thing.id! 'new-val))
(let ([f #f])
;; defeat inlining to ensure that thunk is JITted:
(set! f (lambda () (thing.id! (make-thing 1) 'new-val)))
(err/rt-test (f))))
;; ----------------------------------------
(report-errs)

View File

@ -681,6 +681,7 @@ typedef struct Scheme_Offset_Cptr
#define SCHEME_PRIM_STRUCT_TYPE_CONSTR 128
#define SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER 256
#define SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER (128 | 256)
#define SCHEME_PRIM_STRUCT_TYPE_BROKEN_INDEXED_SETTER (32 | 128)
#define SCHEME_PRIM_TYPE_PARAMETER 64
#define SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER (64 | 128)
#define SCHEME_PRIM_SOMETIMES_INLINED (64 | 256)

View File

@ -2591,6 +2591,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
|| (kind == SCHEME_PRIM_STRUCT_TYPE_CONSTR)
|| (kind == SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER)
|| (kind == SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER)
|| (kind == SCHEME_PRIM_STRUCT_TYPE_BROKEN_INDEXED_SETTER)
|| (kind == SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER)
|| (kind == SCHEME_PRIM_STRUCT_TYPE_PRED)) {
print_named(obj, "struct-procedure",

View File

@ -1325,7 +1325,7 @@ static Scheme_Object *guard_property(Scheme_Object *prop, Scheme_Object *v, Sche
if (SCHEME_INTP(v)) {
intptr_t pos;
pos = SCHEME_INT_VAL(orig_v);
if (!t->immutables || !t->immutables[pos]) {
if (!t->immutables || !t->immutables[pos]) {
scheme_contract_error("make-struct-type",
"field is not specified as immutable for a prop:procedure index",
"index", 1, orig_v,
@ -3040,7 +3040,8 @@ struct_setter_p(int argc, Scheme_Object *argv[])
Scheme_Object *v = argv[0];
if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v);
return ((STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER)
|| STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER))
|| STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER)
|| STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_BROKEN_INDEXED_SETTER))
? scheme_true : scheme_false);
}
@ -3827,6 +3828,8 @@ make_struct_proc(Scheme_Struct_Type *struct_type,
2 + need_pos, 2 + need_pos, 0);
if (need_pos)
flags |= SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER;
else if (struct_type->immutables && struct_type->immutables[field_num])
flags |= SCHEME_PRIM_STRUCT_TYPE_BROKEN_INDEXED_SETTER;
else
flags |= SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER;
/* See note above:
@ -3844,7 +3847,8 @@ Scheme_Object *scheme_rename_struct_proc(Scheme_Object *p, Scheme_Object *sym)
if (SCHEME_PRIMP(p)) {
unsigned short flags = ((Scheme_Primitive_Proc *)p)->pp.flags;
int is_getter = ((flags & SCHEME_PRIM_OTHER_TYPE_MASK) == SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER);
int is_setter = ((flags & SCHEME_PRIM_OTHER_TYPE_MASK) == SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER);
int is_setter = (((flags & SCHEME_PRIM_OTHER_TYPE_MASK) == SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER)
|| ((flags & SCHEME_PRIM_OTHER_TYPE_MASK) == SCHEME_PRIM_STRUCT_TYPE_BROKEN_INDEXED_SETTER));
if (is_getter || is_setter) {
const char *func_name;