From c805728d3e603cd71865e886baf5bcbdeb0a1dbe Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 9 Oct 2011 19:29:21 -0600 Subject: [PATCH] fix compiler confusion: non-mutating vs reorderable unsafe ops 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 --- collects/tests/racket/optimize.rktl | 61 +++++++++++++++++++++++++++++ src/racket/include/scheme.h | 14 +++---- src/racket/src/jit.c | 11 ++++-- src/racket/src/jitcommon.c | 14 +++---- src/racket/src/jitinline.c | 14 +++---- src/racket/src/list.c | 12 ++++-- src/racket/src/number.c | 10 ++--- src/racket/src/optimize.c | 24 ++++++------ src/racket/src/print.c | 12 +++++- src/racket/src/struct.c | 45 ++++++++++++--------- src/racket/src/vector.c | 14 +++---- 11 files changed, 158 insertions(+), 73 deletions(-) diff --git a/collects/tests/racket/optimize.rktl b/collects/tests/racket/optimize.rktl index b7bf2a4028..97e1730007 100644 --- a/collects/tests/racket/optimize.rktl +++ b/collects/tests/racket/optimize.rktl @@ -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 diff --git a/src/racket/include/scheme.h b/src/racket/include/scheme.h index 3aa17d4497..2f7d45efc3 100644 --- a/src/racket/include/scheme.h +++ b/src/racket/include/scheme.h @@ -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) diff --git a/src/racket/src/jit.c b/src/racket/src/jit.c index 3354e60be7..7554ef39bf 100644 --- a/src/racket/src/jit.c +++ b/src/racket/src/jit.c @@ -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 diff --git a/src/racket/src/jitcommon.c b/src/racket/src/jitcommon.c index 53b2dd61e9..55722efadb 100644 --- a/src/racket/src/jitcommon.c +++ b/src/racket/src/jitcommon.c @@ -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) { diff --git a/src/racket/src/jitinline.c b/src/racket/src/jitinline.c index 55754bfaf3..e0ab079d2f 100644 --- a/src/racket/src/jitinline.c +++ b/src/racket/src/jitinline.c @@ -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) { diff --git a/src/racket/src/list.c b/src/racket/src/list.c index be7e3cd2dd..e404edd450 100644 --- a/src/racket/src/list.c +++ b/src/racket/src/list.c @@ -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); diff --git a/src/racket/src/number.c b/src/racket/src/number.c index fb934b182f..368cb0f7e3 100644 --- a/src/racket/src/number.c +++ b/src/racket/src/number.c @@ -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!", diff --git a/src/racket/src/optimize.c b/src/racket/src/optimize.c index f46924be71..5fcffdece9 100644 --- a/src/racket/src/optimize.c +++ b/src/racket/src/optimize.c @@ -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+ 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)); diff --git a/src/racket/src/print.c b/src/racket/src/print.c index 433de3415b..2445279439 100644 --- a/src/racket/src/print.c +++ b/src/racket/src/print.c @@ -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); diff --git a/src/racket/src/struct.c b/src/racket/src/struct.c index 0055ccfb4a..5d330a3822 100644 --- a/src/racket/src/struct.c +++ b/src/racket/src/struct.c @@ -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); - - if (is_getter || is_setter) { - const char *func_name; - Struct_Proc_Info *i; - - func_name = scheme_symbol_name(sym); + 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); - 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); + if (is_getter || is_setter) { + const char *func_name; + Struct_Proc_Info *i; + + func_name = scheme_symbol_name(sym); + + 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); + } } } diff --git a/src/racket/src/vector.c b/src/racket/src/vector.c index f9e3a2312b..db688adc2c 100644 --- a/src/racket/src/vector.c +++ b/src/racket/src/vector.c @@ -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,12 +217,12 @@ 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); SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED; - scheme_add_global_constant("unsafe-string-set!", p, env); + scheme_add_global_constant("unsafe-string-set!", p, env); p = scheme_make_immed_prim(unsafe_bytes_len, "unsafe-bytes-length", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED @@ -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);