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

fix compiler confusion: non-mutating vs reorderable unsafe ops

Browse Source 
Reordering `unsafe-vector-ref' past an `unsafe-vector-set!' was
particularly bad. Meanwhile, some non-mutating operations like
`unsafe-mcar' were treated too conservatively.

Merge to 5.2
This commit is contained in:
Matthew Flatt 2011-10-09 19:29:21 -06:00
parent 051649fc13
commit c805728d3e
11 changed files with 158 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

61
collects/tests/racket/optimize.rktl
View File

@ -1372,6 +1372,67 @@
(require racket/bool)
(list #t)))
;; check omit & reorder possibilities for unsafe
;; operations on mutable values:
(let ()
(define (check-omit-ok expr [yes? #t])
;; can omit:
(test-comp `(module m racket/base
(require racket/unsafe/ops)
(define (f x)
(f x)))
`(module m racket/base
(require racket/unsafe/ops)
(define (f x)
,expr
(f x)))
yes?)
;; cannot reorder:
(test-comp `(module m racket/base
(require racket/unsafe/ops)
(define (f x)
(let ([y ,expr])
(vector-ref x x)
(f x y))))
`(module m racket/base
(require racket/unsafe/ops)
(define (f x)
(vector-ref x x)
(f x ,expr)))
#f))
(map check-omit-ok
'((unsafe-vector-ref x x)
(unsafe-vector*-ref x x)
(unsafe-struct-ref x x)
(unsafe-struct*-ref x x)
(unsafe-mcar x)
(unsafe-mcdr x)
(unsafe-unbox x)
(unsafe-unbox* x)
(unsafe-bytes-ref x x)
(unsafe-string-ref x x)
(unsafe-flvector-ref x x)
(unsafe-fxvector-ref x x)
(unsafe-f64vector-ref x x)
(unsafe-s16vector-ref x x)
(unsafe-u16vector-ref x x)))
(map (lambda (x) (check-omit-ok x #f))
'((unsafe-vector-set! x x x)
(unsafe-vector*-set! x x x)
(unsafe-struct-set! x x x)
(unsafe-struct*-set! x x x)
(unsafe-set-mcar! x x)
(unsafe-set-mcdr! x x)
(unsafe-set-box! x x)
(unsafe-set-box*! x x)
(unsafe-bytes-set! x x x)
(unsafe-string-set! x x x)
(unsafe-flvector-set! x x x)
(unsafe-fxvector-set! x x x)
(unsafe-f64vector-set! x x x)
(unsafe-s16vector-set! x x x)
(unsafe-u16vector-set! x x x))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check bytecode verification of lifted functions

14
src/racket/include/scheme.h
View File

@ -657,10 +657,9 @@ typedef struct Scheme_Offset_Cptr
Do not use them directly. */
#define SCHEME_PRIM_OPT_MASK (1 | 2)
#define SCHEME_PRIM_IS_PRIMITIVE 4
#define SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER 8
#define SCHEME_PRIM_IS_STRUCT_PRED 16
#define SCHEME_PRIM_IS_STRUCT_OTHER 32
#define SCHEME_PRIM_OTHER_TYPE_MASK (64 | 128 | 256)
#define SCHEME_PRIM_IS_UNSAFE_OMITABLE 8
#define SCHEME_PRIM_IS_STRUCT_OTHER 16
#define SCHEME_PRIM_OTHER_TYPE_MASK (32 | 64 | 128 | 256)
#define SCHEME_PRIM_IS_MULTI_RESULT 512
#define SCHEME_PRIM_IS_BINARY_INLINED 1024
#define SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL 2048
@ -682,9 +681,9 @@ typedef struct Scheme_Offset_Cptr
#define SCHEME_PRIM_TYPE_PARAMETER 64
#define SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER (64 | 128)
#define SCHEME_PRIM_SOMETIMES_INLINED (64 | 256)
#define SCHEME_PRIM_TYPE_STRUCT_PROP_PRED (64 | 128 | 256)
#define SCHEME_PRIM_IS_STRUCT_PROC (SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER | SCHEME_PRIM_IS_STRUCT_PRED | SCHEME_PRIM_IS_STRUCT_OTHER)
#define SCHEME_PRIM_STRUCT_TYPE_STRUCT_PROP_PRED (64 | 128 | 256)
#define SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER 32
#define SCHEME_PRIM_STRUCT_TYPE_PRED (32 | 64)
#define SCHEME_PRIM_PROC_FLAGS(x) (((Scheme_Prim_Proc_Header *)x)->flags)
@ -811,7 +810,6 @@ typedef struct {
#define SCHEME_ECONTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_escaping_cont_type)
#define SCHEME_CONT_MARK_SETP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_cont_mark_set_type)
#define SCHEME_PROC_STRUCTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_proc_struct_type)
#define SCHEME_STRUCT_PROCP(obj) (SCHEME_PRIMP(obj) && (((Scheme_Primitive_Proc *)(obj))->pp.flags & SCHEME_PRIM_IS_STRUCT_PROC))
#define SCHEME_CLOSUREP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_closure_type) || SAME_TYPE(SCHEME_TYPE(obj), scheme_case_closure_type))
#define SCHEME_PRIM(obj) (((Scheme_Primitive_Proc *)(obj))->prim_val)

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

@ -495,10 +495,15 @@ int scheme_is_noncm(Scheme_Object *a, mz_jit_state *jitter, int depth, int stack
if (SCHEME_PRIMP(a)) {
int opts;
opts = ((Scheme_Prim_Proc_Header *)a)->flags & SCHEME_PRIM_OPT_MASK;
if (opts >= SCHEME_PRIM_OPT_NONCM)
if (opts >= SCHEME_PRIM_OPT_NONCM) {
/* Structure-type predicates are handled specially, so don't claim NONCM: */
if (!(((Scheme_Prim_Proc_Header *)a)->flags & SCHEME_PRIM_IS_STRUCT_PRED))
return 1;
if (((Scheme_Prim_Proc_Header *)a)->flags & SCHEME_PRIM_IS_STRUCT_OTHER) {
if ((((Scheme_Prim_Proc_Header *)a)->flags & SCHEME_PRIM_OTHER_TYPE_MASK)
== SCHEME_PRIM_STRUCT_TYPE_PRED)
return 0;
}
return 1;
}
}
if (depth

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

@ -1552,14 +1552,12 @@ static int common4(mz_jit_state *jitter, void *_data)
mz_patch_branch(ref);
(void)mz_bnei_t(refslow, JIT_R0, scheme_prim_type, JIT_R2);
jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Primitive_Proc *)0x0)->pp.flags);
if (kind == 3) {
jit_andi_i(JIT_R2, JIT_R2, SCHEME_PRIM_OTHER_TYPE_MASK);
(void)jit_bnei_i(refslow, JIT_R2, SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER);
} else {
(void)jit_bmci_i(refslow, JIT_R2, ((kind == 1)
? SCHEME_PRIM_IS_STRUCT_PRED
: SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER));
}
jit_andi_i(JIT_R2, JIT_R2, SCHEME_PRIM_OTHER_TYPE_MASK);
(void)jit_bnei_i(refslow, JIT_R2, ((kind == 3)
? SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER
: ((kind == 1)
? SCHEME_PRIM_STRUCT_TYPE_PRED
: SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER)));
CHECK_LIMIT();
/* Check argument: */
if (kind == 1) {

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

@ -109,15 +109,15 @@ static int check_val_struct_prim(Scheme_Object *p, int arity)
{
if (p && SCHEME_PRIMP(p)) {
if (arity == 1) {
if (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_PRED)
return 1;
else if (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER)
return 2;
else if (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_OTHER) {
if (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_OTHER) {
int t = (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_OTHER_TYPE_MASK);
if (t == SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER)
if (t == SCHEME_PRIM_STRUCT_TYPE_PRED)
return 1;
if (t == SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER)
return 2;
else if (t == SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER)
return 4;
else if (t == SCHEME_PRIM_TYPE_STRUCT_PROP_PRED)
else if (t == SCHEME_PRIM_STRUCT_TYPE_STRUCT_PROP_PRED)
return 6;
}
} else if (arity == 2) {

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

@ -746,11 +746,13 @@ scheme_init_unsafe_list (Scheme_Env *env)
scheme_add_global_constant ("unsafe-list-tail", p, env);
p = scheme_make_immed_prim(unsafe_mcar, "unsafe-mcar", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_OMITABLE);
scheme_add_global_constant ("unsafe-mcar", p, env);
p = scheme_make_immed_prim(unsafe_mcdr, "unsafe-mcdr", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_OMITABLE);
scheme_add_global_constant ("unsafe-mcdr", p, env);
p = scheme_make_immed_prim(unsafe_set_mcar, "unsafe-set-mcar!", 2, 2);
@ -762,11 +764,13 @@ scheme_init_unsafe_list (Scheme_Env *env)
scheme_add_global_constant ("unsafe-set-mcdr!", p, env);
p = scheme_make_immed_prim(unsafe_unbox, "unsafe-unbox", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_OMITABLE);
scheme_add_global_constant("unsafe-unbox", p, env);
p = scheme_make_immed_prim(unsafe_unbox_star, "unsafe-unbox*", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_OMITABLE);
scheme_add_global_constant("unsafe-unbox*", p, env);
p = scheme_make_immed_prim(unsafe_set_box, "unsafe-set-box!", 2, 2);

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

@ -864,7 +864,7 @@ void scheme_init_unsafe_number(Scheme_Env *env)
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
else
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL;
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNSAFE_OMITABLE;
scheme_add_global_constant("unsafe-f64vector-ref", p, env);
p = scheme_make_immed_prim(fl_set, "unsafe-f64vector-set!",
@ -887,7 +887,7 @@ void scheme_init_unsafe_number(Scheme_Env *env)
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
else
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL;
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNSAFE_OMITABLE;
scheme_add_global_constant("unsafe-flvector-ref", p, env);
p = scheme_make_immed_prim(unsafe_flvector_set, "unsafe-flvector-set!",
@ -904,7 +904,7 @@ void scheme_init_unsafe_number(Scheme_Env *env)
p = scheme_make_immed_prim(unsafe_fxvector_ref, "unsafe-fxvector-ref",
2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
| SCHEME_PRIM_IS_UNSAFE_OMITABLE);
scheme_add_global_constant("unsafe-fxvector-ref", p, env);
p = scheme_make_immed_prim(unsafe_fxvector_set, "unsafe-fxvector-set!",
@ -915,7 +915,7 @@ void scheme_init_unsafe_number(Scheme_Env *env)
p = scheme_make_immed_prim(s16_ref, "unsafe-s16vector-ref",
2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL;
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNSAFE_OMITABLE;
scheme_add_global_constant("unsafe-s16vector-ref", p, env);
p = scheme_make_immed_prim(s16_set, "unsafe-s16vector-set!",
@ -926,7 +926,7 @@ void scheme_init_unsafe_number(Scheme_Env *env)
p = scheme_make_immed_prim(u16_ref, "unsafe-u16vector-ref",
2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL;
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNSAFE_OMITABLE;
scheme_add_global_constant("unsafe-u16vector-ref", p, env);
p = scheme_make_immed_prim(u16_set, "unsafe-u16vector-set!",

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

@ -42,6 +42,8 @@
#define MAX_PROC_INLINE_SIZE 256
#define SCHEME_PRIM_IS_UNSAFE_NONMUTATING (SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_IS_UNSAFE_OMITABLE)
struct Optimize_Info
{
MZTAG_IF_REQUIRED
@ -385,7 +387,7 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
}
}
if (SCHEME_PRIMP(app->args[0])
&& (SCHEME_PRIM_PROC_FLAGS(app->args[0]) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL)
&& (SCHEME_PRIM_PROC_FLAGS(app->args[0]) & SCHEME_PRIM_IS_UNSAFE_NONMUTATING)
&& (app->num_args >= ((Scheme_Primitive_Proc *)app->args[0])->mina)
&& (app->num_args <= ((Scheme_Primitive_Proc *)app->args[0])->mu.maxa)) {
note_match(1, vals, warn_info);
@ -421,7 +423,7 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
}
}
if (SCHEME_PRIMP(app->rator)
&& (SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL)
&& (SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_UNSAFE_NONMUTATING)
&& (1 >= ((Scheme_Primitive_Proc *)app->rator)->mina)
&& (1 <= ((Scheme_Primitive_Proc *)app->rator)->mu.maxa)) {
note_match(1, vals, warn_info);
@ -465,7 +467,7 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
}
}
if (SCHEME_PRIMP(app->rator)
&& (SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL)
&& (SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_UNSAFE_NONMUTATING)
&& (2 >= ((Scheme_Primitive_Proc *)app->rator)->mina)
&& (2 <= ((Scheme_Primitive_Proc *)app->rator)->mu.maxa)) {
note_match(1, vals, warn_info);
@ -1337,10 +1339,10 @@ static Scheme_Object *check_app_let_rator(Scheme_Object *app, Scheme_Object *rat
return NULL;
}
static int purely_functional_primitive(Scheme_Object *rator, int n)
static int is_nonmutating_primitive(Scheme_Object *rator, int n)
{
if (SCHEME_PRIMP(rator)
&& (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL)
&& (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_UNSAFE_NONMUTATING)
&& (n >= ((Scheme_Primitive_Proc *)rator)->mina)
&& (n <= ((Scheme_Primitive_Proc *)rator)->mu.maxa))
return 1;
@ -1363,7 +1365,7 @@ int scheme_wants_flonum_arguments(Scheme_Object *rator, int argpos, int rotate_m
/* In rotate mode, we really want to know whether any argument wants to be lifted out. */
{
if (SCHEME_PRIMP(rator)) {
if (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL) {
if (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_UNSAFE_NONMUTATING) {
if (IS_NAMED_PRIM(rator, "unsafe-flabs")
|| IS_NAMED_PRIM(rator, "unsafe-flsqrt")
|| IS_NAMED_PRIM(rator, "unsafe-fl+")
@ -1424,7 +1426,7 @@ int scheme_wants_flonum_arguments(Scheme_Object *rator, int argpos, int rotate_m
static int produces_unboxed(Scheme_Object *rator, int *non_fl_args, int argc, int for_args)
{
if (SCHEME_PRIMP(rator)) {
if (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL) {
if (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_UNSAFE_NONMUTATING) {
if (((argc == 1)
&& (IS_NAMED_PRIM(rator, "unsafe-flabs")
|| IS_NAMED_PRIM(rator, "unsafe-flsqrt")
@ -1880,7 +1882,7 @@ static Scheme_Object *finish_optimize_application(Scheme_App_Rec *app, Optimize_
}
info->size += 1;
if (!purely_functional_primitive(app->args[0], app->num_args))
if (!is_nonmutating_primitive(app->args[0], app->num_args))
info->vclock += 1;
if (all_vals) {
@ -2027,7 +2029,7 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz
return app->rand;
}
if (!purely_functional_primitive(app->rator, 1))
if (!is_nonmutating_primitive(app->rator, 1))
info->vclock += 1;
info->preserves_marks = !!(rator_flags & CLOS_PRESERVES_MARKS);
@ -2196,7 +2198,7 @@ static Scheme_Object *finish_optimize_application3(Scheme_App3_Rec *app, Optimiz
return le;
}
if (!purely_functional_primitive(app->rator, 2))
if (!is_nonmutating_primitive(app->rator, 2))
info->vclock += 1;
/* Check for (call-with-values (lambda () M) N): */
@ -2272,7 +2274,7 @@ static Scheme_Object *finish_optimize_application3(Scheme_App3_Rec *app, Optimiz
/* Ad hoc optimization of (unsafe-fx+ <x> 0), etc. */
if (SCHEME_PRIMP(app->rator)
&& (SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL)) {
&& (SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_UNSAFE_NONMUTATING)) {
int z1, z2;
z1 = SAME_OBJ(app->rand1, scheme_make_integer(0));

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

@ -2382,7 +2382,17 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
if (compact || !pp->print_unreadable)
cannot_print(pp, notdisplay, obj, ht, compact);
else {
if (SCHEME_STRUCT_PROCP(obj)) {
int kind;
if (((Scheme_Primitive_Proc *)(obj))->pp.flags & SCHEME_PRIM_IS_STRUCT_OTHER)
kind = (((Scheme_Primitive_Proc *)(obj))->pp.flags & SCHEME_PRIM_OTHER_TYPE_MASK);
else
kind = -1;
if ((kind == SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER)
|| (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_INDEXED_GETTER)
|| (kind == SCHEME_PRIM_STRUCT_TYPE_PRED)) {
print_named(obj, "struct-procedure",
((Scheme_Closed_Primitive_Proc *)obj)->name,
-1, pp);

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

@ -1156,7 +1156,7 @@ static Scheme_Object *make_struct_type_property_from_c(int argc, Scheme_Object *
v = scheme_make_folding_prim_closure(prop_pred, 1, a, name, 1, 1, 0);
((Scheme_Closed_Primitive_Proc *)v)->pp.flags |= (SCHEME_PRIM_IS_STRUCT_OTHER
| SCHEME_PRIM_TYPE_STRUCT_PROP_PRED);
| SCHEME_PRIM_STRUCT_TYPE_STRUCT_PROP_PRED);
*predout = v;
name = MALLOC_N_ATOMIC(char, len + 10);
@ -3035,8 +3035,10 @@ struct_getter_p(int argc, Scheme_Object *argv[])
{
Scheme_Object *v = argv[0];
if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v);
return ((STRUCT_PROCP(v, SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER)
|| STRUCT_mPROCP(v,
return ((STRUCT_mPROCP(v,
SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_OTHER_TYPE_MASK,
SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER)
|| STRUCT_mPROCP(v,
SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_OTHER_TYPE_MASK,
SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER))
? scheme_true : scheme_false);
@ -3047,7 +3049,9 @@ struct_pred_p(int argc, Scheme_Object *argv[])
{
Scheme_Object *v = argv[0];
if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v);
return (STRUCT_PROCP(v, SCHEME_PRIM_IS_STRUCT_PRED)
return (STRUCT_mPROCP(v,
SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_OTHER_TYPE_MASK,
SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_TYPE_PRED)
? scheme_true : scheme_false);
}
@ -3783,7 +3787,7 @@ make_struct_proc(Scheme_Struct_Type *struct_type,
1, a,
func_name,
1, 1, 1);
flags |= SCHEME_PRIM_IS_STRUCT_PRED;
flags |= SCHEME_PRIM_STRUCT_TYPE_PRED | SCHEME_PRIM_IS_STRUCT_OTHER;
} else {
Struct_Proc_Info *i;
int need_pos;
@ -3812,7 +3816,7 @@ make_struct_proc(Scheme_Struct_Type *struct_type,
if (need_pos)
flags |= SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER | SCHEME_PRIM_IS_STRUCT_OTHER;
else
flags |= SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER;
flags |= SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER | SCHEME_PRIM_IS_STRUCT_OTHER;
/* Cache the accessor only if `struct_info' is used.
This avoids keep lots of useless accessors.
if (need_pos) struct_type->accessor = p; */
@ -3838,20 +3842,23 @@ make_struct_proc(Scheme_Struct_Type *struct_type,
Scheme_Object *scheme_rename_struct_proc(Scheme_Object *p, Scheme_Object *sym)
{
if (SCHEME_PRIMP(p)) {
int is_getter = (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER);
int is_setter = (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER);
unsigned short flags = ((Scheme_Primitive_Proc *)p)->pp.flags;
if (flags & SCHEME_PRIM_IS_STRUCT_OTHER) {
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);
if (is_getter || is_setter) {
const char *func_name;
Struct_Proc_Info *i;
if (is_getter || is_setter) {
const char *func_name;
Struct_Proc_Info *i;
func_name = scheme_symbol_name(sym);
func_name = scheme_symbol_name(sym);
i = (Struct_Proc_Info *)SCHEME_PRIM_CLOSURE_ELS(p)[0];
i = (Struct_Proc_Info *)SCHEME_PRIM_CLOSURE_ELS(p)[0];
return make_struct_proc(i->struct_type, (char *)func_name,
is_getter ? SCHEME_GETTER : SCHEME_SETTER,
i->field);
return make_struct_proc(i->struct_type, (char *)func_name,
is_getter ? SCHEME_GETTER : SCHEME_SETTER,
i->field);
}
}
}

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

@ -176,12 +176,12 @@ scheme_init_unsafe_vector (Scheme_Env *env)
p = scheme_make_immed_prim(unsafe_vector_ref, "unsafe-vector-ref", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
| SCHEME_PRIM_IS_UNSAFE_OMITABLE);
scheme_add_global_constant("unsafe-vector-ref", p, env);
p = scheme_make_immed_prim(unsafe_vector_star_ref, "unsafe-vector*-ref", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
| SCHEME_PRIM_IS_UNSAFE_OMITABLE);
scheme_add_global_constant("unsafe-vector*-ref", p, env);
p = scheme_make_immed_prim(unsafe_vector_set, "unsafe-vector-set!", 3, 3);
@ -194,12 +194,12 @@ scheme_init_unsafe_vector (Scheme_Env *env)
p = scheme_make_immed_prim(unsafe_struct_ref, "unsafe-struct-ref", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
| SCHEME_PRIM_IS_UNSAFE_OMITABLE);
scheme_add_global_constant("unsafe-struct-ref", p, env);
p = scheme_make_immed_prim(unsafe_struct_star_ref, "unsafe-struct*-ref", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
| SCHEME_PRIM_IS_UNSAFE_OMITABLE);
scheme_add_global_constant("unsafe-struct*-ref", p, env);
p = scheme_make_immed_prim(unsafe_struct_set, "unsafe-struct-set!", 3, 3);
@ -217,7 +217,7 @@ scheme_init_unsafe_vector (Scheme_Env *env)
p = scheme_make_immed_prim(unsafe_string_ref, "unsafe-string-ref", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
| SCHEME_PRIM_IS_UNSAFE_OMITABLE);
scheme_add_global_constant("unsafe-string-ref", p, env);
p = scheme_make_immed_prim(unsafe_string_set, "unsafe-string-set!", 3, 3);
@ -231,7 +231,7 @@ scheme_init_unsafe_vector (Scheme_Env *env)
p = scheme_make_immed_prim(unsafe_bytes_ref, "unsafe-bytes-ref", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
| SCHEME_PRIM_IS_UNSAFE_OMITABLE);
scheme_add_global_constant("unsafe-bytes-ref", p, env);
p = scheme_make_immed_prim(unsafe_bytes_set, "unsafe-bytes-set!", 3, 3);