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

add prop:authentic and (struct .... #:authentic ....)

Browse Source 
An authentic structure type is one whose instances cannot be
impersonated or chaperoned. The intended use of `prop:authentic` is to
annotate a library-private data structure where impersonators are
never needed internally for the data structure, and the declaration
lets the compiler produce less code and fewer branches by omitting
impersonator support.
This commit is contained in:
Matthew Flatt 2017-05-12 07:52:33 -06:00
parent 65beb4de4c
commit f43234e1cb
20 changed files with 980 additions and 781 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi)
(define version "6.9.0.3")
(define version "6.9.0.4")
(define deps `("racket-lib"
["racket" #:version ,version]))

24
pkgs/racket-doc/scribblings/reference/chaperones.scrbl
View File

@ -707,6 +707,30 @@ checked (recursively).
predicates and accessors sensitive
to @racket[prop:impersonator-of].}]}
@defthing[prop:authentic struct-type-property?]{
A @tech{structure type property} that declares a structure type as
@deftech{authentic}. The value associated with the property is ignored;
the presence of the property itself makes the structure type
authentic.
Instances of an @tech{authentic} structure type cannot be impersonated
via @racket[impersonate-struct] or chaperoned via
@racket[chaperone-struct]. As a consequence, an instance of an
@tech{authentic} structure type can be given a contract (see
@racket[struct/c]) only if it is a @tech{flat contract}.
Declaring a structure type as @tech{authentic} can prevent unwanted
structure impersonation, but exposed structure types normally should
support impersonators or chaperones to facilitate contracts. Declaring
a structure type as @tech{authentic} can also slightly improve the
performance of structure predicates, selectors, and mutators, which
can be appropriate for data structures that are private
and frequently used within a library.
@history[#:added "6.9.0.4"]}
@; ------------------------------------------------------------
@section{Chaperone Constructors}

12
pkgs/racket-doc/scribblings/reference/define-struct.scrbl
View File

@ -24,6 +24,7 @@
(code:line #:property prop-expr val-expr)
(code:line #:transparent)
(code:line #:prefab)
(code:line #:authentic)
(code:line #:name name-id)
(code:line #:extra-name name-id)
(code:line #:constructor-name constructor-id)
@ -166,6 +167,14 @@ must also be a @tech{prefab} structure type.
(prefab-point? #s(prefab-point 1 2))
]
The @racket[#:authentic] option is a shorthand for @racket[#:property
prop:authentic #t], which prevents instances of the structure type
from being impersonated (see @racket[impersonate-struct]), chaperoned
(see @racket[chaperone-struct]), or acquiring a non-@tech{flat
contract} (see @racket[struct/c]). See @racket[prop:authentic] for
more information. If a supertype is specified, it must also have the
@racket[prop:authentic] property.
If @racket[name-id] is supplied via @racket[#:extra-name] and it is
not @racket[id], then both @racket[name-id] and @racket[id] are bound
to information about the structure type. Only one of
@ -289,7 +298,8 @@ cp
]
For serialization, see @racket[define-serializable-struct].
}
@history[#:changed "6.9.0.4" @elem{Added @racket[#:authentic].}]}
@defform[(struct-field-index field-id)]{

38
pkgs/racket-test-core/tests/racket/jitinline.rktl
View File

@ -18,11 +18,16 @@
(namespace-require 'racket/unsafe/ops)
(namespace-require 'racket/unsafe/undefined)
(namespace-require '(prefix k: '#%kernel))
(eval '(define-values (prop:thing thing? thing-ref)
(make-struct-type-property 'thing)))
(eval '(struct rock (x) #:property prop:thing 'yes))
(eval '(module rock racket/base
(provide (all-defined-out))
(define-values (prop:thing thing? thing-ref)
(make-struct-type-property 'thing))
(struct rock (x) #:property prop:thing 'yes)
(struct stone (x) #:authentic)))
(eval '(require 'rock))
(let* ([struct:rock (eval 'struct:rock)]
[a-rock (eval '(rock 0))]
[a-stone (eval '(stone 0))]
[chap-rock (eval '(chaperone-struct (rock 0) rock-x (lambda (r v) (add1 v))))]
[check-error-message (lambda (name proc [fixnum? #f]
#:bad-value [bad-value (if fixnum? 10 'bad)]
@ -39,7 +44,7 @@
exact-integer?
exact-nonnegative-integer?
exact-positive-integer?
thing?
thing? rock? stone?
continuation-mark-set-first))
(let ([s (with-handlers ([exn? exn-message])
(let ([bad bad-value])
@ -221,8 +226,18 @@
(un #t 'bytes? #"apple")
(un #f 'thing? 10)
(un #t 'thing? a-rock)
(un #f 'thing? a-stone)
(un #t 'thing? chap-rock)
(un #t 'thing? struct:rock)
(un #f 'rock? 10)
(un #t 'rock? a-rock)
(un #f 'rock? a-stone)
(un #t 'rock? chap-rock)
(un #f 'rock? struct:rock)
(un #f 'stone? 10)
(un #f 'stone? a-rock)
(un #t 'stone? a-stone)
(un #f 'stone? chap-rock)
(un #f 'immutable? (vector 1 2 3))
(un #t 'immutable? (vector-immutable 1 2 3))
(un #f 'immutable? (box 1))
@ -901,12 +916,13 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check JIT handling of structure-reference sequencese
;; Check JIT handling of structure-reference sequences
(for ([options '(() (#:authentic))])
(parameterize ([current-namespace (make-base-namespace)]
[eval-jit-enabled #t])
(eval '(module paper racket/base
(eval `(module paper racket/base
(provide (all-defined-out))
(struct paper (width height folds) #:transparent)
(struct paper (width height folds) #:transparent ,@options)
(define (fold-letter l)
(for/fold ([l l]) ([i (in-range 100)])
(and (paper? l)
@ -917,15 +933,17 @@
(struct-copy paper l [width i]))))))
(eval '(require 'paper))
(eval '(define letter (paper 8.5 11 0)))
(unless (equal? options '(#:authentic))
(eval '(define formal-letter (chaperone-struct letter paper-height
(lambda (s v)
(unless (equal? v 11)
(error "wrong"))
v))))
v)))))
(test #t eval '(equal? (fold-letter letter) (paper 8.5 11 99)))
(test #t eval '(equal? (fold-letter formal-letter) (paper 8.5 11 99)))
(test #t eval '(equal? (refine-letter letter) (paper 99 11 0)))
(test #t eval '(equal? (refine-letter formal-letter) (paper 99 11 0))))
(unless (equal? options '(#:authentic))
(test #t eval '(equal? (fold-letter formal-letter) (paper 8.5 11 99)))
(test #t eval '(equal? (refine-letter formal-letter) (paper 99 11 0))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Make sure the JIT handles struct-type property predicates and

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

@ -3428,6 +3428,22 @@
(unsafe-struct-ref v 1))
(void)))))
(test-comp '(module m racket/base
(require racket/unsafe/ops)
(struct a (x y) #:authentic)
(define (f v)
(if (a? v)
(list (a-x v) (a-y v))
(void))))
'(module m racket/base
(require racket/unsafe/ops)
(struct a (x y) #:authentic)
(define (f v)
(if (a? v)
(list (unsafe-struct*-ref v 0)
(unsafe-struct*-ref v 1))
(void)))))
(test-comp '(module m racket/base
(require racket/unsafe/ops)
(struct a (x y))

22
pkgs/racket-test-core/tests/racket/struct.rktl
View File

@ -1176,6 +1176,28 @@
(test 'blinky ghost-name (struct-copy GHOST (ghost 'red 'blinky)))
(syntax-test #'GHOST)
;; ----------------------------------------
;; Check `#:authentic`:
(let ()
(struct posn (x y) #:authentic)
(test 1 posn-x (posn 1 2))
(err/rt-test (chaperone-struct (posn 1 2) posn-x (lambda (p x) x)))
;; Subtype must be consistent:
(err/rt-test (let ()
(struct posn3D posn (z))
'ok)))
(let ()
(struct posn (x y))
;; Subtype must be consistent:
(err/rt-test (let ()
(struct posn3D posn (z)
#:authentic)
'ok)))
;; ----------------------------------------
(report-errs)

14
racket/collects/racket/private/define-struct.rkt
View File

@ -240,6 +240,7 @@
(#:reflection-name . #f)
(#:name . #f)
(#:only-name? . #f)
(#:authentic . #f)
(#:omit-define-values . #f)
(#:omit-define-syntaxes . #f))]
[nongen? #f])
@ -319,6 +320,12 @@
(loop (cdr p)
(extend-config config '#:inspector #'#f)
nongen?)]
[(eq? '#:authentic (syntax-e (car p)))
(when (lookup config '#:authentic)
(bad "multiple" "#:authentic" "s" (car p)))
(loop (cdr p)
(extend-config config '#:authentic #'#t)
nongen?)]
[(or (eq? '#:constructor-name (syntax-e (car p)))
(eq? '#:extra-constructor-name (syntax-e (car p))))
(check-exprs 1 p "identifier")
@ -452,7 +459,12 @@
(let ([config (parse-props #'fm (syntax->list #'(prop ...)) super-id)])
(values (lookup config '#:inspector)
(lookup config '#:super)
(lookup config '#:props)
(let ([l (lookup config '#:props)]
[a (lookup config '#:authentic)])
(if a
(cons (cons #'prop:authentic #'#t)
l)
l))
(lookup config '#:auto-value)
(lookup config '#:guard)
(lookup config '#:constructor-name)

1340
racket/src/racket/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

1
racket/src/racket/src/jit.h
View File

@ -1525,6 +1525,7 @@ int scheme_generate_struct_op(mz_jit_state *jitter, int kind, int for_branch,
int result_ignored,
int check_proc, int check_arg_fixnum,
int type_pos, int field_pos,
int authentic,
int pop_and_jump,
jit_insn *refslow, jit_insn *refslow2,
jit_insn *bref_false, jit_insn *bref_true);

17
racket/src/racket/src/jitcall.c
View File

@ -2421,10 +2421,10 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
static int detect_unsafe_struct_refs(Scheme_Object *arg, Scheme_Object **alt_rands, Scheme_App_Rec *app,
int i, int num_rands, int shift)
/* Look for `(unsafe-struct-ref id 'num)` ... as a sequence of
/* Look for `(unsafe-struct[*]-ref id 'num)` ... as a sequence of
arguments, which shows up as a result of `struct-copy`, and return
the length of the sequence. Instead of performing each
`unsafe-struct-ref` separately, which involves a chaperone test
`unsafe-struct[*]-ref` separately, which can involve a chaperone test
each time, we'll test once and extract all. */
{
Scheme_App3_Rec *app3, *next_app3;
@ -2432,7 +2432,8 @@ static int detect_unsafe_struct_refs(Scheme_Object *arg, Scheme_Object **alt_ran
if (SAME_TYPE(SCHEME_TYPE(arg), scheme_application3_type)) {
app3 = (Scheme_App3_Rec *)arg;
if (SAME_OBJ(app3->rator, scheme_unsafe_struct_ref_proc)
if ((SAME_OBJ(app3->rator, scheme_unsafe_struct_ref_proc)
|| SAME_OBJ(app3->rator, scheme_unsafe_struct_star_ref_proc))
&& SAME_TYPE(SCHEME_TYPE(app3->rand1), scheme_local_type)
&& SCHEME_INTP(app3->rand2)) {
int seq = 1, delta = SCHEME_INT_VAL(app3->rand2) - i;
@ -2441,7 +2442,8 @@ static int detect_unsafe_struct_refs(Scheme_Object *arg, Scheme_Object **alt_ran
next_arg = (alt_rands ? alt_rands[i+shift] : app->args[i+shift]);
if (SAME_TYPE(SCHEME_TYPE(next_arg), scheme_application3_type)) {
next_app3 = (Scheme_App3_Rec *)next_arg;
if (SAME_OBJ(next_app3->rator, scheme_unsafe_struct_ref_proc)
if ((SAME_OBJ(next_app3->rator, scheme_unsafe_struct_ref_proc)
|| SAME_OBJ(next_app3->rator, scheme_unsafe_struct_star_ref_proc))
&& SAME_TYPE(SCHEME_TYPE(next_app3->rand1), scheme_local_type)
&& SCHEME_INTP(next_app3->rand2)
&& (SCHEME_INT_VAL(next_app3->rand2) == i + delta)
@ -2466,7 +2468,7 @@ static int generate_unsafe_struct_ref_sequence(mz_jit_state *jitter, Scheme_Obje
{
Scheme_App3_Rec *app3 = (Scheme_App3_Rec *)arg;
int i, base = SCHEME_INT_VAL(app3->rand2);
GC_CAN_IGNORE jit_insn *ref, *refslow, *ref2;
GC_CAN_IGNORE jit_insn *ref2;
/* Using `last_arg` ensures that we clear the local, if needed */
mz_runstack_skipped(jitter, 2);
@ -2476,6 +2478,8 @@ static int generate_unsafe_struct_ref_sequence(mz_jit_state *jitter, Scheme_Obje
/* Check for chaperones, and take slow path if found */
__START_SHORT_JUMPS__(1);
if (SAME_OBJ(app3->rator, scheme_unsafe_struct_ref_proc)) {
GC_CAN_IGNORE jit_insn *ref, *refslow;
jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type);
ref = jit_bnei_i(jit_forward(), JIT_R2, scheme_chaperone_type);
refslow = jit_get_ip();
@ -2488,6 +2492,8 @@ static int generate_unsafe_struct_ref_sequence(mz_jit_state *jitter, Scheme_Obje
mz_patch_branch(ref);
(void)jit_beqi_i(refslow, JIT_R2, scheme_proc_chaperone_type);
CHECK_LIMIT();
} else
ref2 = NULL;
/* This is the fast path: */
for (i = 0; i < count; i++) {
@ -2499,6 +2505,7 @@ static int generate_unsafe_struct_ref_sequence(mz_jit_state *jitter, Scheme_Obje
CHECK_LIMIT();
}
if (ref2)
mz_patch_branch(ref2);
__END_SHORT_JUMPS__(1);

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

@ -1562,6 +1562,7 @@ int scheme_generate_struct_op(mz_jit_state *jitter, int kind, int for_branch,
int result_ignored,
int check_proc, int check_arg_fixnum,
int type_pos, int field_pos,
int authentic,
int pop_and_jump,
GC_CAN_IGNORE jit_insn *refslow, GC_CAN_IGNORE jit_insn *refslow2,
GC_CAN_IGNORE jit_insn *bref_false, GC_CAN_IGNORE jit_insn *bref_true)
@ -1593,6 +1594,7 @@ int scheme_generate_struct_op(mz_jit_state *jitter, int kind, int for_branch,
jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Object *)0x0)->type);
__START_INNER_TINY__(1);
ref2 = jit_beqi_i(jit_forward(), JIT_R2, scheme_structure_type);
if (!authentic) {
ref3 = jit_beqi_i(jit_forward(), JIT_R2, scheme_proc_struct_type);
CHECK_LIMIT();
ref9 = jit_beqi_i(jit_forward(), JIT_R2, scheme_chaperone_type);
@ -1604,6 +1606,9 @@ int scheme_generate_struct_op(mz_jit_state *jitter, int kind, int for_branch,
jit_ldxi_p(JIT_R1, JIT_R1, &SCHEME_CHAPERONE_VAL(0x0));
(void)jit_jmpi(refretry);
mz_patch_branch(ref3);
} else {
bref2 = jit_bnei_i(jit_forward(), JIT_R2, scheme_proc_struct_type);
}
__END_INNER_TINY__(1);
} else {
if (check_arg_fixnum) {
@ -1713,12 +1718,14 @@ int scheme_generate_struct_op(mz_jit_state *jitter, int kind, int for_branch,
/* False branch: */
if (branch_info) {
scheme_add_branch_false(branch_info, bref1);
if (bref2)
scheme_add_branch_false(branch_info, bref2);
if (bref3)
scheme_add_branch_false(branch_info, bref3);
scheme_add_branch_false(branch_info, bref4);
} else {
mz_patch_branch(bref1);
if (bref2)
mz_patch_branch(bref2);
if (bref3)
mz_patch_branch(bref3);
@ -2036,7 +2043,7 @@ static int common4(mz_jit_state *jitter, void *_data)
__END_SHORT_JUMPS__(1);
scheme_generate_struct_op(jitter, kind, for_branch, NULL, 1, 0,
1, 1, -1, -1,
1, 1, -1, -1, 0,
1, refslow, refslow2, bref5, bref6);
CHECK_LIMIT();

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

@ -678,9 +678,11 @@ static int generate_inlined_struct_op(int kind, mz_jit_state *jitter,
}
if (inline_rator) {
int pos, tpos, jkind;
int pos, tpos, jkind, authentic;
tpos = ((Scheme_Struct_Type *)((Scheme_Primitive_Closure *)inline_rator)->val[0])->name_pos;
authentic = ((Scheme_Struct_Type *)((Scheme_Primitive_Closure *)inline_rator)->val[0])->authentic;
if (kind == INLINE_STRUCT_PROC_PRED) {
pos = 0;
} else {
@ -709,6 +711,7 @@ static int generate_inlined_struct_op(int kind, mz_jit_state *jitter,
result_ignored,
0, 0,
tpos, pos,
authentic,
0, refslow, refslow, NULL, NULL);
CHECK_LIMIT();

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

@ -4566,7 +4566,7 @@ static void setup_accessible_table(Scheme_Module *m)
if (SAME_TYPE(SCHEME_TYPE(form), scheme_define_values_type)) {
int checked_st = 0, is_st_prop = 0, has_guard = 0;
Scheme_Object *is_st = NULL;
Simple_Stuct_Type_Info stinfo;
Simple_Struct_Type_Info stinfo;
Scheme_Object *parent_identity;
for (k = SCHEME_VEC_SIZE(form); k-- > 1; ) {
tl = SCHEME_VEC_ELS(form)[k];

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

@ -409,7 +409,8 @@ int scheme_is_struct_functional(Scheme_Object *rator, int num_args, Optimize_Inf
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)
int mode = (SCHEME_PROP_PROC_SHAPE_MODE(c) & STRUCT_PROC_SHAPE_MASK);
if ((mode == STRUCT_PROP_PROC_SHAPE_PRED)
&& (num_args == 1))
return 1;
}
@ -1190,7 +1191,7 @@ static int ok_proc_creator_args(Scheme_Object *rator, Scheme_Object *rand1, Sche
}
static int is_values_with_accessors_and_mutators(Scheme_Object *e, int vals, int resolved,
Simple_Stuct_Type_Info *_stinfo,
Simple_Struct_Type_Info *_stinfo,
Scheme_IR_Local **vars)
/* Does `e` produce values for a structure type, mutators, and accessors in the
usual order? */
@ -1421,7 +1422,7 @@ static int ok_constant_property_with_guard(void *data, Scheme_Object *v, int mod
if (mode == OK_CONSTANT_SHAPE) {
if (SAME_TYPE(SCHEME_TYPE(v), scheme_struct_prop_proc_shape_type)) {
k = SCHEME_PROC_SHAPE_MODE(v);
k = SCHEME_PROP_PROC_SHAPE_MODE(v);
}
} else if (mode == OK_CONSTANT_ENCODED_SHAPE) {
if (!scheme_decode_struct_prop_shape(v, &k))
@ -1469,7 +1470,8 @@ static int is_simple_property_list(Scheme_Object *a, int resolved,
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 **symbols, Scheme_Hash_Table *symbol_table,
int just_for_authentic, int *_authentic)
/* Does `a` produce a property list that always lets `make-struct-type` succeed? */
{
Scheme_Object *arg;
@ -1505,8 +1507,13 @@ static int is_simple_property_list(Scheme_Object *a, int resolved,
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))
if (!SAME_OBJ(a3->rator, scheme_cons_proc)) {
if (!just_for_authentic)
return 0;
} else {
if (_authentic && SAME_OBJ(a3->rand1, scheme_authentic_property))
*_authentic = 1;
if (!just_for_authentic) {
if (is_struct_type_property_without_guard(a3->rand1,
top_level_consts,
inline_variants, top_level_table,
@ -1516,16 +1523,20 @@ static int is_simple_property_list(Scheme_Object *a, int resolved,
return 0;
} else
return 0;
} else
}
}
} else {
if (!just_for_authentic)
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,
Simple_Struct_Type_Info *_stinfo,
Scheme_Object **_parent_identity,
Scheme_Hash_Table *top_level_consts,
Scheme_Hash_Table *inline_variants,
@ -1592,7 +1603,8 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, in
top_level_consts, inline_variants,
top_level_table,
runstack, rs_delta,
symbols, symbol_table)))
symbols, symbol_table,
0, NULL)))
&& ((app->num_args < 7)
/* inspector: */
|| SCHEME_FALSEP(app->args[7])
@ -1620,6 +1632,7 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, in
if (_name)
*_name = app->args[1];
if (_stinfo) {
int authentic = 0;
int super_count = (super_count_plus_one
? (super_count_plus_one - 1)
: 0);
@ -1631,6 +1644,15 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, in
_stinfo->super_field_count = (super_count_plus_one ? (super_count_plus_one - 1) : 0);
_stinfo->normal_ops = 1;
_stinfo->indexed_ops = 0;
_stinfo->authentic = 0;
if ((app->num_args > 6)
&& is_simple_property_list(app->args[6], resolved,
top_level_consts, inline_variants,
top_level_table,
runstack, rs_delta,
symbols, symbol_table,
1, &authentic))
_stinfo->authentic = authentic;
_stinfo->num_gets = 1;
_stinfo->num_sets = 1;
}
@ -1649,7 +1671,7 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, in
Scheme_IR_Let_Value *lv = (Scheme_IR_Let_Value *)lh->body;
if (SAME_TYPE(SCHEME_TYPE(lv->value), scheme_application_type)) {
Scheme_Object *auto_e;
Simple_Stuct_Type_Info stinfo;
Simple_Struct_Type_Info stinfo;
if (!_stinfo) _stinfo = &stinfo;
auto_e = scheme_is_simple_make_struct_type(lv->value, 5, flags,
_auto_e_depth, _stinfo, _parent_identity,
@ -1681,7 +1703,7 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, in
e2 = skip_clears(lv->value);
if (SAME_TYPE(SCHEME_TYPE(e2), scheme_application_type)) {
Scheme_Object *auto_e;
Simple_Stuct_Type_Info stinfo;
Simple_Struct_Type_Info stinfo;
if (!_stinfo) _stinfo = &stinfo;
auto_e = scheme_is_simple_make_struct_type(e2, 5, flags,
_auto_e_depth, _stinfo, _parent_identity,
@ -1753,12 +1775,14 @@ int scheme_is_simple_make_struct_type_property(Scheme_Object *e, int vals, int f
/* more utils */
/*========================================================================*/
intptr_t scheme_get_struct_proc_shape(int k, Simple_Stuct_Type_Info *stinfo)
intptr_t scheme_get_struct_proc_shape(int k, Simple_Struct_Type_Info *stinfo)
{
switch (k) {
case 0:
if (stinfo->field_count == stinfo->init_field_count)
return STRUCT_PROC_SHAPE_STRUCT | (stinfo->field_count << STRUCT_PROC_SHAPE_SHIFT);
return (STRUCT_PROC_SHAPE_STRUCT
| (stinfo->authentic ? STRUCT_PROC_SHAPE_AUTHENTIC : 0)
| (stinfo->field_count << STRUCT_PROC_SHAPE_SHIFT));
else
return STRUCT_PROC_SHAPE_OTHER;
break;
@ -1766,16 +1790,20 @@ intptr_t scheme_get_struct_proc_shape(int k, Simple_Stuct_Type_Info *stinfo)
return STRUCT_PROC_SHAPE_CONSTR | (stinfo->init_field_count << STRUCT_PROC_SHAPE_SHIFT);
break;
case 2:
return STRUCT_PROC_SHAPE_PRED;
return (STRUCT_PROC_SHAPE_PRED
| (stinfo->authentic ? STRUCT_PROC_SHAPE_AUTHENTIC : 0));
break;
default:
if (stinfo && stinfo->normal_ops && stinfo->indexed_ops) {
if (k - 3 < stinfo->num_gets) {
/* record index of field */
return (STRUCT_PROC_SHAPE_GETTER
| (stinfo->authentic ? STRUCT_PROC_SHAPE_AUTHENTIC : 0)
| ((stinfo->super_field_count + (k - 3)) << STRUCT_PROC_SHAPE_SHIFT));
} else
return (STRUCT_PROC_SHAPE_SETTER | (stinfo->field_count << STRUCT_PROC_SHAPE_SHIFT));
return (STRUCT_PROC_SHAPE_SETTER
| (stinfo->authentic ? STRUCT_PROC_SHAPE_AUTHENTIC : 0)
| (stinfo->field_count << STRUCT_PROC_SHAPE_SHIFT));
}
}
@ -4561,7 +4589,9 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz
} else {
/* Struct type matches, so use `unsafe-struct-ref` */
Scheme_App3_Rec *new;
new = (Scheme_App3_Rec *)make_application_3(scheme_unsafe_struct_ref_proc,
new = (Scheme_App3_Rec *)make_application_3(((SCHEME_PROC_SHAPE_MODE(alt) & STRUCT_PROC_SHAPE_AUTHENTIC)
? scheme_unsafe_struct_star_ref_proc
: scheme_unsafe_struct_ref_proc),
app->rand,
scheme_make_integer(SCHEME_PROC_SHAPE_MODE(alt) >> STRUCT_PROC_SHAPE_SHIFT),
info);
@ -8813,7 +8843,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
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;
Simple_Struct_Type_Info stinfo;
vars = SCHEME_VEC_ELS(e)[0];
e = SCHEME_VEC_ELS(e)[1];

2
racket/src/racket/src/schminc.h
View File

@ -14,7 +14,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1155
#define EXPECTED_PRIM_COUNT 1156
#define EXPECTED_UNSAFE_COUNT 133
#define EXPECTED_FLFXNUM_COUNT 69
#define EXPECTED_EXTFL_COUNT 45

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

@ -536,6 +536,7 @@ extern Scheme_Object *scheme_vector_set_proc;
extern Scheme_Object *scheme_list_to_vector_proc;
extern Scheme_Object *scheme_unsafe_vector_length_proc;
extern Scheme_Object *scheme_unsafe_struct_ref_proc;
extern Scheme_Object *scheme_unsafe_struct_star_ref_proc;
extern Scheme_Object *scheme_hash_ref_proc;
extern Scheme_Object *scheme_box_p_proc;
extern Scheme_Object *scheme_box_proc;
@ -651,6 +652,8 @@ extern Scheme_Object *scheme_app_mark_impersonator_property;
extern Scheme_Object *scheme_no_arity_property;
extern Scheme_Object *scheme_authentic_property;
extern Scheme_Object *scheme_chaperone_undefined_property;
extern Scheme_Object *scheme_reduced_procedure_struct;
@ -1045,6 +1048,7 @@ typedef struct Scheme_Struct_Type {
mzshort num_slots; /* initialized + auto + parent-initialized + parent-auto */
mzshort num_islots; /* initialized + parent-initialized */
mzshort name_pos;
char authentic; /* 1 => chaperones/impersonators disallowed */
Scheme_Object *name;
@ -3518,12 +3522,13 @@ typedef struct {
int init_field_count; /* number of fields supplied to the constructor; usually == field_count */
int normal_ops; /* are selectors and predicates in the usual order? */
int indexed_ops; /* do selectors have the index built in (as opposed to taking an index argument)? */
int authentic; /* conservatively 0 is ok */
int num_gets, num_sets;
} Simple_Stuct_Type_Info;
} Simple_Struct_Type_Info;
Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *app, int vals, int flags,
int *_auto_e_depth,
Simple_Stuct_Type_Info *_stinfo,
Simple_Struct_Type_Info *_stinfo,
Scheme_Object **_parent_identity,
Scheme_Hash_Table *top_level_consts,
Scheme_Hash_Table *inline_variants,
@ -3545,7 +3550,7 @@ int scheme_is_simple_make_struct_type_property(Scheme_Object *app, int vals, int
#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);
intptr_t scheme_get_struct_proc_shape(int k, Simple_Struct_Type_Info *sinfo);
Scheme_Object *scheme_make_struct_proc_shape(intptr_t k, Scheme_Object *identity);
#define STRUCT_PROC_SHAPE_STRUCT 0
#define STRUCT_PROC_SHAPE_CONSTR 1
@ -3554,7 +3559,8 @@ Scheme_Object *scheme_make_struct_proc_shape(intptr_t k, Scheme_Object *identity
#define STRUCT_PROC_SHAPE_SETTER 4
#define STRUCT_PROC_SHAPE_OTHER 5
#define STRUCT_PROC_SHAPE_MASK 0xF
#define STRUCT_PROC_SHAPE_SHIFT 4
#define STRUCT_PROC_SHAPE_AUTHENTIC 0x10
#define STRUCT_PROC_SHAPE_SHIFT 5
typedef struct Scheme_Struct_Proc_Shape {
Scheme_Object so;

4
racket/src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "6.9.0.3"
#define MZSCHEME_VERSION "6.9.0.4"
#define MZSCHEME_VERSION_X 6
#define MZSCHEME_VERSION_Y 9
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 3
#define MZSCHEME_VERSION_W 4
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

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

@ -50,6 +50,7 @@ READ_ONLY Scheme_Object *scheme_app_mark_impersonator_property;
READ_ONLY Scheme_Object *scheme_liberal_def_ctx_type;;
READ_ONLY Scheme_Object *scheme_object_name_property;
READ_ONLY Scheme_Object *scheme_struct_to_vector_proc;
READ_ONLY Scheme_Object *scheme_authentic_property;
READ_ONLY static Scheme_Object *location_struct;
READ_ONLY static Scheme_Object *write_property;
@ -536,6 +537,12 @@ scheme_init_struct (Scheme_Env *env)
scheme_add_global_constant("prop:method-arity-error", method_property, env);
}
{
REGISTER_SO(scheme_authentic_property);
scheme_authentic_property = scheme_make_struct_type_property(scheme_intern_symbol("authentic"));
scheme_add_global_constant("prop:authentic", scheme_authentic_property, env);
}
REGISTER_SO(not_free_id_symbol);
not_free_id_symbol = scheme_intern_symbol("not-free-identifier=?");
@ -3603,7 +3610,8 @@ int scheme_check_structure_shape(Scheme_Object *e, Scheme_Object *expected)
if (st->num_slots != st->num_islots)
return (v == STRUCT_PROC_SHAPE_OTHER);
return (v == ((st->num_slots << STRUCT_PROC_SHAPE_SHIFT)
| STRUCT_PROC_SHAPE_STRUCT));
| STRUCT_PROC_SHAPE_STRUCT
| (st->authentic ? STRUCT_PROC_SHAPE_AUTHENTIC : 0)));
} else if (!SCHEME_PRIMP(e))
return 0;
@ -3614,16 +3622,20 @@ int scheme_check_structure_shape(Scheme_Object *e, Scheme_Object *expected)
return (v == ((st->num_islots << STRUCT_PROC_SHAPE_SHIFT)
| STRUCT_PROC_SHAPE_CONSTR));
} else if (i == SCHEME_PRIM_STRUCT_TYPE_PRED) {
return (v == STRUCT_PROC_SHAPE_PRED);
st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0];
return (v == (STRUCT_PROC_SHAPE_PRED
| (st->authentic ? STRUCT_PROC_SHAPE_AUTHENTIC : 0)));
} else if (i == SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER) {
st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0];
return (v == ((st->num_slots << STRUCT_PROC_SHAPE_SHIFT)
| STRUCT_PROC_SHAPE_SETTER));
| STRUCT_PROC_SHAPE_SETTER
| (st->authentic ? STRUCT_PROC_SHAPE_AUTHENTIC : 0)));
} else if (i == SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER) {
int pos = SCHEME_INT_VAL(SCHEME_PRIM_CLOSURE_ELS(e)[1]);
st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0];
return (v == ((pos << STRUCT_PROC_SHAPE_SHIFT)
| STRUCT_PROC_SHAPE_GETTER));
| STRUCT_PROC_SHAPE_GETTER
| (st->authentic ? STRUCT_PROC_SHAPE_AUTHENTIC : 0)));
} else if ((i == SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER)
|| (i == SCHEME_PRIM_STRUCT_TYPE_BROKEN_INDEXED_SETTER)
|| (i == SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER))
@ -4862,6 +4874,7 @@ Scheme_Struct_Type *scheme_make_prefab_struct_type_raw(Scheme_Object *base,
struct_type->num_slots = num_fields + num_uninit_fields + (parent_type ? parent_type->num_slots : 0);
struct_type->num_islots = num_fields + (parent_type ? parent_type->num_islots : 0);
struct_type->name_pos = depth;
struct_type->authentic = 0;
struct_type->inspector = scheme_false;
struct_type->uninit_val = uninit_val;
struct_type->props = NULL;
@ -5048,6 +5061,8 @@ static Scheme_Object *_make_struct_type(Scheme_Object *base,
checked_proc = 1;
if (SAME_OBJ(prop, scheme_chaperone_undefined_property))
chaperone_undefined = 1;
if (SAME_OBJ(prop, scheme_authentic_property))
struct_type->authentic = 1;
propv = guard_property(prop, SCHEME_CDR(a), struct_type);
@ -5108,6 +5123,8 @@ static Scheme_Object *_make_struct_type(Scheme_Object *base,
checked_proc = 1;
if (SAME_OBJ(prop, scheme_chaperone_undefined_property))
chaperone_undefined = 1;
if (SAME_OBJ(prop, scheme_authentic_property))
struct_type->authentic = 1;
propv = guard_property(prop, SCHEME_CDR(a), struct_type);
@ -5161,6 +5178,20 @@ static Scheme_Object *_make_struct_type(Scheme_Object *base,
}
}
if (parent_type && (parent_type->authentic != struct_type->authentic)) {
if (parent_type->authentic)
scheme_contract_error("make-struct-type",
"cannot make a non-authentic subtype of an authentic type",
"type name", 1, struct_type->name,
"authentic type", 1, parent,
NULL);
else
scheme_contract_error("make-struct-type",
"cannot make an authentic subtype of a non-authentic type",
"type name", 1, struct_type->name,
"non-authentic type", 1, parent,
NULL);
}
if (guard) {
if (!scheme_check_proc_arity(NULL, struct_type->num_islots + 1, -1, 0, &guard)) {
@ -6367,6 +6398,16 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
return NULL;
}
if (SCHEME_STRUCTP(val) && ((Scheme_Structure *)val)->stype->authentic) {
scheme_contract_error(name,
(is_impersonator
? "cannot impersonate instance of an authentic structure type"
: "cannot chaperone instance of an authentic structure type"),
"given value", 1, val,
NULL);
return NULL;
}
if (!redirects) {
/* a non-structure chaperone */
redirects = scheme_make_vector(1, NULL);

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

@ -306,7 +306,7 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port,
Scheme_Hash_Table **_st_ht)
{
int i, size, flags, result, is_struct, is_struct_prop, has_guard;
Simple_Stuct_Type_Info stinfo;
Simple_Struct_Type_Info stinfo;
Scheme_Object *val, *only_var;
val = SCHEME_VEC_ELS(data)[0];
@ -1422,7 +1422,6 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
/* check expectation */
if (((tl_state[p] & SCHEME_TOPLEVEL_FLAGS_MASK) < flags)
|| ((tl_state[p] >> 2) > tl_timestamp)) {
printf("?? %d\n", p);
scheme_ill_formed_code(port);
}
}

3
racket/src/racket/src/vector.c
View File

@ -38,6 +38,7 @@ READ_ONLY Scheme_Object *scheme_unsafe_vector_length_proc;
READ_ONLY Scheme_Object *scheme_unsafe_string_length_proc;
READ_ONLY Scheme_Object *scheme_unsafe_byte_string_length_proc;
READ_ONLY Scheme_Object *scheme_unsafe_struct_ref_proc;
READ_ONLY Scheme_Object *scheme_unsafe_struct_star_ref_proc;
/* locals */
static Scheme_Object *vector_p (int argc, Scheme_Object *argv[]);
@ -239,7 +240,9 @@ scheme_init_unsafe_vector (Scheme_Env *env)
| SCHEME_PRIM_IS_OMITABLE);
scheme_add_global_constant("unsafe-struct-ref", p, env);
REGISTER_SO(scheme_unsafe_struct_ref_proc);
p = scheme_make_immed_prim(unsafe_struct_star_ref, "unsafe-struct*-ref", 2, 2);
scheme_unsafe_struct_star_ref_proc = p;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_OMITABLE
| SCHEME_PRIM_IS_OMITABLE);