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

remove a level of indirection in struct selectors/mutators

Browse Source
This commit is contained in:
Matthew Flatt 2012-10-26 12:49:42 -06:00
parent 736e6efc2d
commit e698be778b
7 changed files with 124 additions and 179 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
src/racket/src/jitcommon.c
View File

@ -1494,9 +1494,6 @@ int scheme_generate_struct_op(mz_jit_state *jitter, int kind, int for_branch,
jit_ldxi_p(JIT_R2, JIT_R1, &((Scheme_Structure *)0x0)->stype); jit_ldxi_p(JIT_R2, JIT_R1, &((Scheme_Structure *)0x0)->stype);
if (type_pos < 0) { if (type_pos < 0) {
jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val); jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val);
if (kind >= 2) {
jit_ldxi_p(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->struct_type);
}
} }
CHECK_LIMIT(); CHECK_LIMIT();
@ -1547,9 +1544,6 @@ int scheme_generate_struct_op(mz_jit_state *jitter, int kind, int for_branch,
/* (Re-)load target type into V1: */ /* (Re-)load target type into V1: */
jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val); jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val);
if (kind >= 2) {
jit_ldxi_p(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->struct_type);
}
if (kind == 1) { if (kind == 1) {
bref4 = jit_bner_p(jit_forward(), JIT_R2, JIT_V1); bref4 = jit_bner_p(jit_forward(), JIT_R2, JIT_V1);
@ -1616,8 +1610,8 @@ int scheme_generate_struct_op(mz_jit_state *jitter, int kind, int for_branch,
} }
/* Extract field */ /* Extract field */
if (field_pos < 0) { if (field_pos < 0) {
jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val); jit_ldxi_p(JIT_V1, JIT_R0, &(((Scheme_Primitive_Closure *)0x0)->val[1]));
jit_ldxi_i(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->field); jit_rshi_ul(JIT_V1, JIT_V1, 1);
jit_lshi_ul(JIT_V1, JIT_V1, JIT_LOG_WORD_SIZE); jit_lshi_ul(JIT_V1, JIT_V1, JIT_LOG_WORD_SIZE);
jit_addi_p(JIT_V1, JIT_V1, &((Scheme_Structure *)0x0)->slots); jit_addi_p(JIT_V1, JIT_V1, &((Scheme_Structure *)0x0)->slots);
} else { } else {

8
src/racket/src/jitinline.c
View File

@ -396,7 +396,7 @@ static int generate_inlined_struct_op(int kind, mz_jit_state *jitter,
/* R0 is [potential] predicate/getter/setting, R1 is struct. /* R0 is [potential] predicate/getter/setting, R1 is struct.
V1 is value for setting. */ V1 is value for setting. */
if ((kind == INLINE_STRUCT_PROC_PRED) /* REMOVEME */ if ((kind == INLINE_STRUCT_PROC_PRED)
|| (kind == INLINE_STRUCT_PROC_GET) || (kind == INLINE_STRUCT_PROC_GET)
|| (kind == INLINE_STRUCT_PROC_SET)) { || (kind == INLINE_STRUCT_PROC_SET)) {
inline_rator = extract_struct_constant(jitter, rator); inline_rator = extract_struct_constant(jitter, rator);
@ -489,13 +489,11 @@ static int generate_inlined_struct_op(int kind, mz_jit_state *jitter,
if (inline_rator) { if (inline_rator) {
int pos, tpos, jkind; int pos, tpos, jkind;
inline_rator = ((Scheme_Primitive_Closure *)inline_rator)->val[0]; tpos = ((Scheme_Struct_Type *)((Scheme_Primitive_Closure *)inline_rator)->val[0])->name_pos;
if (kind == INLINE_STRUCT_PROC_PRED) { if (kind == INLINE_STRUCT_PROC_PRED) {
pos = 0; pos = 0;
tpos = ((Scheme_Struct_Type *)inline_rator)->name_pos;
} else { } else {
pos = ((Struct_Proc_Info *)inline_rator)->field; pos = SCHEME_INT_VAL(((Scheme_Primitive_Closure *)inline_rator)->val[1]);
tpos = ((Struct_Proc_Info *)inline_rator)->struct_type->name_pos;
} }
if (ref) { if (ref) {

29
src/racket/src/mzmark_struct.inc
View File

@ -153,35 +153,6 @@ static int mark_struct_type_val_FIXUP(void *p, struct NewGC *gc) {
#define mark_struct_type_val_IS_CONST_SIZE 0 #define mark_struct_type_val_IS_CONST_SIZE 0
static int mark_struct_proc_info_SIZE(void *p, struct NewGC *gc) {
return
gcBYTES_TO_WORDS(sizeof(Struct_Proc_Info));
}
static int mark_struct_proc_info_MARK(void *p, struct NewGC *gc) {
Struct_Proc_Info *i = (Struct_Proc_Info *)p;
gcMARK2(i->struct_type, gc);
gcMARK2(i->func_name, gc);
return
gcBYTES_TO_WORDS(sizeof(Struct_Proc_Info));
}
static int mark_struct_proc_info_FIXUP(void *p, struct NewGC *gc) {
Struct_Proc_Info *i = (Struct_Proc_Info *)p;
gcFIXUP2(i->struct_type, gc);
gcFIXUP2(i->func_name, gc);
return
gcBYTES_TO_WORDS(sizeof(Struct_Proc_Info));
}
#define mark_struct_proc_info_IS_ATOMIC 0
#define mark_struct_proc_info_IS_CONST_SIZE 1
static int mark_struct_property_SIZE(void *p, struct NewGC *gc) { static int mark_struct_property_SIZE(void *p, struct NewGC *gc) {
return return
gcBYTES_TO_WORDS(sizeof(Scheme_Struct_Property)); gcBYTES_TO_WORDS(sizeof(Scheme_Struct_Property));

11
src/racket/src/mzmarksrc.c
View File

@ -2102,17 +2102,6 @@ mark_struct_type_val {
* sizeof(Scheme_Struct_Type *)))); * sizeof(Scheme_Struct_Type *))));
} }
mark_struct_proc_info {
mark:
Struct_Proc_Info *i = (Struct_Proc_Info *)p;
gcMARK2(i->struct_type, gc);
gcMARK2(i->func_name, gc);
size:
gcBYTES_TO_WORDS(sizeof(Struct_Proc_Info));
}
mark_struct_property { mark_struct_property {
mark: mark:
Scheme_Struct_Property *i = (Scheme_Struct_Property *)p; Scheme_Struct_Property *i = (Scheme_Struct_Property *)p;

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

@ -791,13 +791,6 @@ typedef struct Scheme_Serialized_Structure
} Scheme_Serialized_Structure; } Scheme_Serialized_Structure;
#endif #endif
typedef struct Struct_Proc_Info {
MZTAG_IF_REQUIRED
Scheme_Struct_Type *struct_type;
char *func_name;
mzshort field;
} Struct_Proc_Info;
#define SCHEME_STRUCT_TYPE(o) (((Scheme_Structure *)o)->stype) #define SCHEME_STRUCT_TYPE(o) (((Scheme_Structure *)o)->stype)
#define SCHEME_STRUCT_NUM_SLOTS(o) (SCHEME_STRUCT_TYPE(o)->num_slots) #define SCHEME_STRUCT_NUM_SLOTS(o) (SCHEME_STRUCT_TYPE(o)->num_slots)

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

@ -1370,14 +1370,19 @@ static Scheme_Object *guard_property(Scheme_Object *prop, Scheme_Object *v, Sche
static int extract_accessor_offset(Scheme_Object *acc) static int extract_accessor_offset(Scheme_Object *acc)
{ {
Struct_Proc_Info *i = (Struct_Proc_Info *)SCHEME_PRIM_CLOSURE_ELS(acc)[0]; Scheme_Struct_Type *st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(acc)[0];
if (i->struct_type->name_pos) if (st->name_pos)
return i->struct_type->parent_types[i->struct_type->name_pos - 1]->num_slots; return st->parent_types[st->name_pos - 1]->num_slots;
else else
return 0; return 0;
} }
static char *extract_field_proc_name(Scheme_Object *prim)
{
return (char *)SCHEME_PRIM_CLOSURE_ELS(prim)[2];
}
typedef int (*Check_Val_Proc)(Scheme_Object *); typedef int (*Check_Val_Proc)(Scheme_Object *);
static void wrong_property_contract(const char *name, const char *contract, Scheme_Object *v) static void wrong_property_contract(const char *name, const char *contract, Scheme_Object *v)
@ -2304,16 +2309,17 @@ static Scheme_Object *struct_pred(int argc, Scheme_Object **args, Scheme_Object
return scheme_false; return scheme_false;
} }
static int parse_pos(const char *who, Struct_Proc_Info *i, Scheme_Object **args, int argc) static int parse_pos(const char *who, Scheme_Object *prim, Scheme_Object **args, int argc)
{ {
int pos; int pos;
Scheme_Struct_Type *st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(prim)[0];
if (!SCHEME_INTP(args[1]) || (SCHEME_INT_VAL(args[1]) < 0)) { if (!SCHEME_INTP(args[1]) || (SCHEME_INT_VAL(args[1]) < 0)) {
if (SCHEME_BIGNUMP(args[1]) && SCHEME_BIGPOS(args[1])) { if (SCHEME_BIGNUMP(args[1]) && SCHEME_BIGPOS(args[1])) {
pos = 32769; /* greater than max field count */ pos = 32769; /* greater than max field count */
} else { } else {
if (!who) if (!who)
who = i->func_name; who = extract_field_proc_name(prim);
scheme_wrong_contract(who, scheme_wrong_contract(who,
"exact-nonnegative-integer?", "exact-nonnegative-integer?",
1, argc, args); 1, argc, args);
@ -2322,20 +2328,20 @@ static int parse_pos(const char *who, Struct_Proc_Info *i, Scheme_Object **args,
} else } else
pos = SCHEME_INT_VAL(args[1]); pos = SCHEME_INT_VAL(args[1]);
if ((pos < i->struct_type->num_slots) if ((pos < st->num_slots)
&& i->struct_type->name_pos) && st->name_pos)
pos += i->struct_type->parent_types[i->struct_type->name_pos - 1]->num_slots; pos += st->parent_types[st->name_pos - 1]->num_slots;
if (pos >= i->struct_type->num_slots) { if (pos >= st->num_slots) {
int sc; int sc;
if (!who) if (!who)
who = i->func_name; who = extract_field_proc_name(prim);
sc = (i->struct_type->name_pos sc = (st->name_pos
? (i->struct_type->num_slots ? (st->num_slots
- i->struct_type->parent_types[i->struct_type->name_pos - 1]->num_slots) - st->parent_types[st->name_pos - 1]->num_slots)
: i->struct_type->num_slots); : st->num_slots);
scheme_contract_error(who, scheme_contract_error(who,
"index too large", "index too large",
@ -2354,29 +2360,29 @@ Scheme_Object *scheme_struct_getter(int argc, Scheme_Object **args, Scheme_Objec
{ {
Scheme_Structure *inst; Scheme_Structure *inst;
int pos; int pos;
Struct_Proc_Info *i = (Struct_Proc_Info *)SCHEME_PRIM_CLOSURE_ELS(prim)[0]; Scheme_Struct_Type *st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(prim)[0];
inst = (Scheme_Structure *)args[0]; inst = (Scheme_Structure *)args[0];
if (SCHEME_CHAPERONEP(((Scheme_Object *)inst))) if (SCHEME_CHAPERONEP(((Scheme_Object *)inst)))
inst = (Scheme_Structure *)SCHEME_CHAPERONE_VAL((Scheme_Object *)inst); inst = (Scheme_Structure *)SCHEME_CHAPERONE_VAL((Scheme_Object *)inst);
if (!SCHEME_STRUCTP(((Scheme_Object *)inst))) { if (!SCHEME_STRUCTP(((Scheme_Object *)inst))) {
scheme_wrong_contract(i->func_name, scheme_wrong_contract(extract_field_proc_name(prim),
pred_name_string(i->struct_type->name), pred_name_string(st->name),
0, argc, args); 0, argc, args);
return NULL; return NULL;
} else if (!STRUCT_TYPEP(i->struct_type, inst)) { } else if (!STRUCT_TYPEP(st, inst)) {
wrong_struct_type(i->func_name, wrong_struct_type(extract_field_proc_name(prim),
i->struct_type->name, st->name,
SCHEME_STRUCT_NAME_SYM(inst), SCHEME_STRUCT_NAME_SYM(inst),
0, argc, args); 0, argc, args);
return NULL; return NULL;
} }
if (argc == 2) if (argc == 2)
pos = parse_pos(NULL, i, args, argc); pos = parse_pos(NULL, prim, args, argc);
else else
pos = i->field; pos = SCHEME_INT_VAL(SCHEME_PRIM_CLOSURE_ELS(prim)[1]);
if (SAME_OBJ((Scheme_Object *)inst, args[0])) if (SAME_OBJ((Scheme_Object *)inst, args[0]))
return inst->slots[pos]; return inst->slots[pos];
@ -2389,44 +2395,43 @@ Scheme_Object *scheme_struct_setter(int argc, Scheme_Object **args, Scheme_Objec
Scheme_Structure *inst; Scheme_Structure *inst;
int pos; int pos;
Scheme_Object *v; Scheme_Object *v;
Struct_Proc_Info *i = (Struct_Proc_Info *)SCHEME_PRIM_CLOSURE_ELS(prim)[0]; Scheme_Struct_Type *st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(prim)[0];
inst = (Scheme_Structure *)args[0]; inst = (Scheme_Structure *)args[0];
if (SCHEME_CHAPERONEP(((Scheme_Object *)inst))) if (SCHEME_CHAPERONEP(((Scheme_Object *)inst)))
inst = (Scheme_Structure *)SCHEME_CHAPERONE_VAL((Scheme_Object *)inst); inst = (Scheme_Structure *)SCHEME_CHAPERONE_VAL((Scheme_Object *)inst);
if (!SCHEME_STRUCTP(((Scheme_Object *)inst))) { if (!SCHEME_STRUCTP(((Scheme_Object *)inst))) {
scheme_wrong_contract(i->func_name, scheme_wrong_contract(extract_field_proc_name(prim),
pred_name_string(i->struct_type->name), pred_name_string(st->name),
0, argc, args); 0, argc, args);
return NULL; return NULL;
} }
if (!STRUCT_TYPEP(i->struct_type, inst)) { if (!STRUCT_TYPEP(st, inst)) {
wrong_struct_type(i->func_name, wrong_struct_type(extract_field_proc_name(prim),
i->struct_type->name, st->name,
SCHEME_STRUCT_NAME_SYM(inst), SCHEME_STRUCT_NAME_SYM(inst),
0, argc, args); 0, argc, args);
return NULL; return NULL;
} }
if (argc == 3) { if (argc == 3) {
pos = parse_pos(NULL, i, args, argc); pos = parse_pos(NULL, prim, args, argc);
v = args[2]; v = args[2];
} else { } else {
pos = i->field; pos = SCHEME_INT_VAL(SCHEME_PRIM_CLOSURE_ELS(prim)[1]);
v = args[1]; v = args[1];
} }
if (i->struct_type->immutables) { if (st->immutables) {
Scheme_Struct_Type *t = i->struct_type;
int p = pos; int p = pos;
if (t->name_pos) if (st->name_pos)
p -= t->parent_types[t->name_pos - 1]->num_slots; p -= st->parent_types[st->name_pos - 1]->num_slots;
if (t->immutables[p]) { if (st->immutables[p]) {
scheme_contract_error(i->func_name, scheme_contract_error(extract_field_proc_name(prim),
"cannot modify value of immutable field in structure", "cannot modify value of immutable field in structure",
"structure", 1, args[0], "structure", 1, args[0],
"field index", 1, scheme_make_integer(pos), "field index", 1, scheme_make_integer(pos),
@ -3104,12 +3109,12 @@ chaperone_prop_getter_p(int argc, Scheme_Object *argv[])
static Scheme_Object *make_struct_field_xxor(const char *who, int getter, static Scheme_Object *make_struct_field_xxor(const char *who, int getter,
int argc, Scheme_Object *argv[]) int argc, Scheme_Object *argv[])
{ {
Struct_Proc_Info *i;
int pos; int pos;
char *name; char *name;
const char *fieldstr; const char *fieldstr;
char digitbuf[20]; char digitbuf[20];
int fieldstrlen; int fieldstrlen;
Scheme_Struct_Type *st;
/* We don't allow chaperones on the getter or setter procedure, because we /* We don't allow chaperones on the getter or setter procedure, because we
can't preserve them in the generated procedure. */ can't preserve them in the generated procedure. */
@ -3124,9 +3129,7 @@ static Scheme_Object *make_struct_field_xxor(const char *who, int getter,
return NULL; return NULL;
} }
i = (Struct_Proc_Info *)SCHEME_PRIM_CLOSURE_ELS(argv[0])[0]; pos = parse_pos(who, argv[0], argv, argc);
pos = parse_pos(who, i, argv, argc);
if (argc > 2) { if (argc > 2) {
if (SCHEME_FALSEP(argv[2])) { if (SCHEME_FALSEP(argv[2])) {
@ -3146,20 +3149,22 @@ static Scheme_Object *make_struct_field_xxor(const char *who, int getter,
fieldstrlen = strlen(fieldstr); fieldstrlen = strlen(fieldstr);
} }
st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(argv[0])[0];
if (!fieldstr) { if (!fieldstr) {
if (getter) if (getter)
name = "accessor"; name = "accessor";
else else
name = "mutator"; name = "mutator";
} else if (getter) { } else if (getter) {
name = (char *)GET_NAME((char *)i->struct_type->name, -1, name = (char *)GET_NAME((char *)st->name, -1,
fieldstr, fieldstrlen, 0); fieldstr, fieldstrlen, 0);
} else { } else {
name = (char *)SET_NAME((char *)i->struct_type->name, -1, name = (char *)SET_NAME((char *)st->name, -1,
fieldstr, fieldstrlen, 0); fieldstr, fieldstrlen, 0);
} }
return make_struct_proc(i->struct_type, return make_struct_proc(st,
name, name,
(getter ? SCHEME_GETTER : SCHEME_SETTER), pos); (getter ? SCHEME_GETTER : SCHEME_SETTER), pos);
} }
@ -3774,7 +3779,7 @@ make_struct_proc(Scheme_Struct_Type *struct_type,
char *func_name, char *func_name,
Scheme_ProcT proc_type, int field_num) Scheme_ProcT proc_type, int field_num)
{ {
Scheme_Object *p, *a[1]; Scheme_Object *p, *a[3];
short flags = 0; short flags = 0;
if (proc_type == SCHEME_CONSTR) { if (proc_type == SCHEME_CONSTR) {
@ -3800,28 +3805,21 @@ make_struct_proc(Scheme_Struct_Type *struct_type,
1, 1, 1); 1, 1, 1);
flags |= SCHEME_PRIM_STRUCT_TYPE_PRED; flags |= SCHEME_PRIM_STRUCT_TYPE_PRED;
} else { } else {
Struct_Proc_Info *i;
int need_pos; int need_pos;
i = MALLOC_ONE_RT(Struct_Proc_Info);
#ifdef MZTAG_REQUIRED
i->type = scheme_rt_struct_proc_info;
#endif
i->struct_type = struct_type;
i->func_name = func_name;
i->field = field_num;
if ((proc_type == SCHEME_GEN_GETTER) if ((proc_type == SCHEME_GEN_GETTER)
|| (proc_type == SCHEME_GEN_SETTER)) || (proc_type == SCHEME_GEN_SETTER))
need_pos = 1; need_pos = 1;
else else
need_pos = 0; need_pos = 0;
a[0] = (Scheme_Object *)i; a[0] = (Scheme_Object *)struct_type;
a[1] = scheme_make_integer(field_num);
a[2] = (Scheme_Object *)func_name;
if ((proc_type == SCHEME_GETTER) || (proc_type == SCHEME_GEN_GETTER)) { if ((proc_type == SCHEME_GETTER) || (proc_type == SCHEME_GEN_GETTER)) {
p = scheme_make_folding_prim_closure(scheme_struct_getter, p = scheme_make_folding_prim_closure(scheme_struct_getter,
1, a, 3, a,
func_name, func_name,
1 + need_pos, 1 + need_pos, 0); 1 + need_pos, 1 + need_pos, 0);
if (need_pos) if (need_pos)
@ -3833,7 +3831,7 @@ make_struct_proc(Scheme_Struct_Type *struct_type,
if (need_pos) struct_type->accessor = p; */ if (need_pos) struct_type->accessor = p; */
} else { } else {
p = scheme_make_folding_prim_closure(scheme_struct_setter, p = scheme_make_folding_prim_closure(scheme_struct_setter,
1, a, 3, a,
func_name, func_name,
2 + need_pos, 2 + need_pos, 0); 2 + need_pos, 2 + need_pos, 0);
if (need_pos) if (need_pos)
@ -3870,15 +3868,17 @@ Scheme_Object *scheme_rename_struct_proc(Scheme_Object *p, Scheme_Object *sym)
if (is_getter || is_setter) { if (is_getter || is_setter) {
const char *func_name; const char *func_name;
Struct_Proc_Info *i; Scheme_Struct_Type *st;
int field_pos;
func_name = scheme_symbol_name(sym); func_name = scheme_symbol_name(sym);
i = (Struct_Proc_Info *)SCHEME_PRIM_CLOSURE_ELS(p)[0]; st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(p)[0];
field_pos = SCHEME_INT_VAL(SCHEME_PRIM_CLOSURE_ELS(p)[1]);
return make_struct_proc(i->struct_type, (char *)func_name, return make_struct_proc(st, (char *)func_name,
is_getter ? SCHEME_GETTER : SCHEME_SETTER, is_getter ? SCHEME_GETTER : SCHEME_SETTER,
i->field); field_pos);
} }
} }
@ -5205,14 +5205,14 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
/* (chaperone-struct v mutator/selector redirect-proc ...) */ /* (chaperone-struct v mutator/selector redirect-proc ...) */
{ {
Scheme_Chaperone *px; Scheme_Chaperone *px;
Scheme_Struct_Type *stype; Scheme_Struct_Type *stype, *st;
Scheme_Object *val = argv[0], *proc; Scheme_Object *val = argv[0], *proc;
Scheme_Object *redirects, *prop, *si_chaperone = scheme_false; Scheme_Object *redirects, *prop, *si_chaperone = scheme_false;
Struct_Proc_Info *pi;
Scheme_Object *a[1], *inspector, *getter_positions = scheme_null; Scheme_Object *a[1], *inspector, *getter_positions = scheme_null;
int i, offset, arity, non_applicable_op, repeat_op; int i, offset, arity, non_applicable_op, repeat_op;
const char *kind; const char *kind;
Scheme_Hash_Tree *props = NULL, *red_props = NULL, *setter_positions = NULL; Scheme_Hash_Tree *props = NULL, *red_props = NULL, *setter_positions = NULL;
intptr_t field_pos;
if (argc == 1) return argv[0]; if (argc == 1) return argv[0];
@ -5276,12 +5276,14 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
"struct-info procedure supplied a second time", "struct-info procedure supplied a second time",
"procedure", 1, a[0], "procedure", 1, a[0],
NULL); NULL);
pi = NULL; st = NULL;
field_pos = 0;
prop = NULL; prop = NULL;
arity = 2; arity = 2;
} else if (offset == -1) { } else if (offset == -1) {
prop = SCHEME_PRIM_CLOSURE_ELS(proc)[0]; prop = SCHEME_PRIM_CLOSURE_ELS(proc)[0];
pi = NULL; st = NULL;
field_pos = 0;
if (is_impersonator if (is_impersonator
&& !((Scheme_Struct_Property *)prop)->can_impersonate) && !((Scheme_Struct_Property *)prop)->can_impersonate)
@ -5303,22 +5305,23 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
arity = 2; arity = 2;
} }
} else { } else {
pi = (Struct_Proc_Info *)((Scheme_Primitive_Closure *)proc)->val[0]; st = (Scheme_Struct_Type *)((Scheme_Primitive_Closure *)proc)->val[0];
field_pos = SCHEME_INT_VAL(((Scheme_Primitive_Closure *)proc)->val[1]);
prop = NULL; prop = NULL;
if (!SCHEME_STRUCTP(val) || !scheme_is_struct_instance((Scheme_Object *)pi->struct_type, val)) if (!SCHEME_STRUCTP(val) || !scheme_is_struct_instance((Scheme_Object *)st, val))
non_applicable_op = 1; non_applicable_op = 1;
else if (SCHEME_TRUEP(SCHEME_VEC_ELS(redirects)[PRE_REDIRECTS + offset + pi->field])) else if (SCHEME_TRUEP(SCHEME_VEC_ELS(redirects)[PRE_REDIRECTS + offset + field_pos]))
repeat_op = 1; repeat_op = 1;
else { else {
if (is_impersonator) { if (is_impersonator) {
intptr_t field_pos; intptr_t loc_field_pos;
field_pos = pi->field - (pi->struct_type->name_pos loc_field_pos = field_pos - (st->name_pos
? pi->struct_type->parent_types[pi->struct_type->name_pos - 1]->num_slots ? st->parent_types[st->name_pos - 1]->num_slots
: 0); : 0);
/* Must not be an immutable field. */ /* Must not be an immutable field. */
if (stype->immutables) { if (stype->immutables) {
if (stype->immutables[field_pos]) if (stype->immutables[loc_field_pos])
scheme_contract_error(name, scheme_contract_error(name,
"cannot replace operation for an immutable field", "cannot replace operation for an immutable field",
"operation kind", 0, kind, "operation kind", 0, kind,
@ -5329,15 +5332,15 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
/* impersonating a getter is allowed only if the structure type is /* impersonating a getter is allowed only if the structure type is
transparent or if the setter is also impersonated (which would prove transparent or if the setter is also impersonated (which would prove
that the code creating the impersonator has suitable access). */ that the code creating the impersonator has suitable access). */
if (!scheme_inspector_sees_part(argv[0], inspector, pi->field)) { if (!scheme_inspector_sees_part(argv[0], inspector, field_pos)) {
getter_positions = scheme_make_pair(scheme_make_pair(scheme_make_integer(pi->field), a[0]), getter_positions = scheme_make_pair(scheme_make_pair(scheme_make_integer(field_pos), a[0]),
getter_positions); getter_positions);
} }
} else { } else {
if (!scheme_inspector_sees_part(argv[0], inspector, pi->field)) { if (!scheme_inspector_sees_part(argv[0], inspector, field_pos)) {
if (!setter_positions) if (!setter_positions)
setter_positions = scheme_make_hash_tree(0); setter_positions = scheme_make_hash_tree(0);
setter_positions = scheme_hash_tree_set(setter_positions, scheme_make_integer(pi->field), scheme_true); setter_positions = scheme_hash_tree_set(setter_positions, scheme_make_integer(field_pos), scheme_true);
} }
} }
} }
@ -5384,8 +5387,8 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
if (prop) if (prop)
red_props = scheme_hash_tree_set(red_props, prop, proc); red_props = scheme_hash_tree_set(red_props, prop, proc);
else if (pi) else if (st)
SCHEME_VEC_ELS(redirects)[PRE_REDIRECTS + offset + pi->field] = proc; SCHEME_VEC_ELS(redirects)[PRE_REDIRECTS + offset + field_pos] = proc;
else else
si_chaperone = proc; si_chaperone = proc;
} }
@ -5550,8 +5553,6 @@ static void register_traversers(void)
GC_REG_TRAV(scheme_nack_guard_evt_type, mark_nack_guard_evt); GC_REG_TRAV(scheme_nack_guard_evt_type, mark_nack_guard_evt);
GC_REG_TRAV(scheme_poll_evt_type, mark_nack_guard_evt); GC_REG_TRAV(scheme_poll_evt_type, mark_nack_guard_evt);
GC_REG_TRAV(scheme_rt_struct_proc_info, mark_struct_proc_info);
GC_REG_TRAV(scheme_chaperone_type, mark_chaperone); GC_REG_TRAV(scheme_chaperone_type, mark_chaperone);
GC_REG_TRAV(scheme_proc_chaperone_type, mark_chaperone); GC_REG_TRAV(scheme_proc_chaperone_type, mark_chaperone);
} }

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

@ -238,44 +238,43 @@ enum {
scheme_rt_tcp_select_info, /* 214 */ scheme_rt_tcp_select_info, /* 214 */
scheme_rt_param_data, /* 215 */ scheme_rt_param_data, /* 215 */
scheme_rt_will, /* 216 */ scheme_rt_will, /* 216 */
scheme_rt_struct_proc_info, /* 217 */ scheme_rt_linker_name, /* 217 */
scheme_rt_linker_name, /* 218 */ scheme_rt_param_map, /* 218 */
scheme_rt_param_map, /* 219 */ scheme_rt_finalization, /* 219 */
scheme_rt_finalization, /* 220 */ scheme_rt_finalizations, /* 220 */
scheme_rt_finalizations, /* 221 */ scheme_rt_cpp_object, /* 221 */
scheme_rt_cpp_object, /* 222 */ scheme_rt_cpp_array_object, /* 222 */
scheme_rt_cpp_array_object, /* 223 */ scheme_rt_stack_object, /* 223 */
scheme_rt_stack_object, /* 224 */ scheme_rt_preallocated_object, /* 224 */
scheme_rt_preallocated_object, /* 225 */ scheme_thread_hop_type, /* 225 */
scheme_thread_hop_type, /* 226 */ scheme_rt_srcloc, /* 226 */
scheme_rt_srcloc, /* 227 */ scheme_rt_evt, /* 227 */
scheme_rt_evt, /* 228 */ scheme_rt_syncing, /* 228 */
scheme_rt_syncing, /* 229 */ scheme_rt_comp_prefix, /* 229 */
scheme_rt_comp_prefix, /* 230 */ scheme_rt_user_input, /* 230 */
scheme_rt_user_input, /* 231 */ scheme_rt_user_output, /* 231 */
scheme_rt_user_output, /* 232 */ scheme_rt_compact_port, /* 232 */
scheme_rt_compact_port, /* 233 */ scheme_rt_read_special_dw, /* 233 */
scheme_rt_read_special_dw, /* 234 */ scheme_rt_regwork, /* 234 */
scheme_rt_regwork, /* 235 */ scheme_rt_rx_lazy_string, /* 235 */
scheme_rt_rx_lazy_string, /* 236 */ scheme_rt_buf_holder, /* 236 */
scheme_rt_buf_holder, /* 237 */ scheme_rt_parameterization, /* 237 */
scheme_rt_parameterization, /* 238 */ scheme_rt_print_params, /* 238 */
scheme_rt_print_params, /* 239 */ scheme_rt_read_params, /* 239 */
scheme_rt_read_params, /* 240 */ scheme_rt_native_code, /* 240 */
scheme_rt_native_code, /* 241 */ scheme_rt_native_code_plus_case, /* 241 */
scheme_rt_native_code_plus_case, /* 242 */ scheme_rt_jitter_data, /* 242 */
scheme_rt_jitter_data, /* 243 */ scheme_rt_module_exports, /* 243 */
scheme_rt_module_exports, /* 244 */ scheme_rt_delay_load_info, /* 244 */
scheme_rt_delay_load_info, /* 245 */ scheme_rt_marshal_info, /* 245 */
scheme_rt_marshal_info, /* 246 */ scheme_rt_unmarshal_info, /* 246 */
scheme_rt_unmarshal_info, /* 247 */ scheme_rt_runstack, /* 247 */
scheme_rt_runstack, /* 248 */ scheme_rt_sfs_info, /* 248 */
scheme_rt_sfs_info, /* 249 */ scheme_rt_validate_clearing, /* 249 */
scheme_rt_validate_clearing, /* 250 */ scheme_rt_avl_node, /* 250 */
scheme_rt_avl_node, /* 251 */ scheme_rt_lightweight_cont, /* 251 */
scheme_rt_lightweight_cont, /* 252 */ scheme_rt_export_info, /* 252 */
scheme_rt_export_info, /* 253 */ scheme_rt_cont_jmp, /* 253 */
scheme_rt_cont_jmp, /* 254 */
#endif #endif
_scheme_last_type_ _scheme_last_type_