From 8c092f093bb044b903d47e8b49427a9762e57735 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 11 Jan 2012 06:58:39 -0700 Subject: [PATCH] clean up and generalize optimizer support for omittable primitives For example, the optimizer knew to drop `(cons x y)' if the result is unused, but not `(pair? x)'. --- collects/tests/racket/optimize.rktl | 56 ++++++++++- src/racket/include/scheme.h | 4 +- src/racket/src/bool.c | 18 ++-- src/racket/src/char.c | 3 +- src/racket/src/file.c | 3 +- src/racket/src/fun.c | 19 ++-- src/racket/src/jit.c | 8 +- src/racket/src/jitinline.c | 35 ++++--- src/racket/src/list.c | 50 ++++++---- src/racket/src/number.c | 72 ++++++++------ src/racket/src/optimize.c | 145 ++++++++-------------------- src/racket/src/portfun.c | 3 +- src/racket/src/print.c | 5 +- src/racket/src/string.c | 6 +- src/racket/src/struct.c | 92 +++++++----------- src/racket/src/symbol.c | 3 +- src/racket/src/vector.c | 27 ++++-- 17 files changed, 278 insertions(+), 271 deletions(-) diff --git a/collects/tests/racket/optimize.rktl b/collects/tests/racket/optimize.rktl index 51297553a7..a9a0793ec6 100644 --- a/collects/tests/racket/optimize.rktl +++ b/collects/tests/racket/optimize.rktl @@ -1346,11 +1346,65 @@ (test-dropped cons-name 1 2) (test-dropped cons-name 1 2 3) (test-dropped cons-name 1) - (test-dropped cons-name))]) + (unless (eq? cons-name 'list*) + (test-dropped cons-name)))]) (test-multi 'list) (test-multi 'list*) (test-multi 'vector) (test-multi 'vector-immutable))) +(test-comp `(let ([x 5]) + (let ([y (list*)]) + x)) + 5 + #f) + +(let ([test-pred + (lambda (pred-name) + (test-comp `(lambda (z) + (let ([x ',pred-name]) + (let ([y (,pred-name z)]) + x))) + `(lambda (z) ',pred-name)))]) + (test-pred 'pair?) + (test-pred 'mpair?) + (test-pred 'list?) + (test-pred 'box?) + (test-pred 'number?) + (test-pred 'real?) + (test-pred 'complex?) + (test-pred 'rational?) + (test-pred 'integer?) + (test-pred 'exact-integer?) + (test-pred 'exact-nonnegative-integer?) + (test-pred 'exact-positive-integer?) + (test-pred 'inexact-real?) + (test-pred 'fixnum?) + (test-pred 'flonum?) + (test-pred 'single-flonum?) + (test-pred 'null?) + (test-pred 'void?) + (test-pred 'symbol?) + (test-pred 'string?) + (test-pred 'bytes?) + (test-pred 'path?) + (test-pred 'char?) + (test-pred 'boolean?) + (test-pred 'chaperone?) + (test-pred 'impersonator?) + (test-pred 'procedure?) + (test-pred 'eof-object?) + (test-pred 'not)) + +(let ([test-bin + (lambda (bin-name) + (test-comp `(lambda (z) + (let ([x ',bin-name]) + (let ([y (,bin-name z z)]) + x))) + `(lambda (z) ',bin-name)))]) + (test-bin 'eq?) + (test-bin 'eqv?)) + ;; + fold to fixnum overflow, fx+ doesn't (test-comp `(module m racket/base diff --git a/src/racket/include/scheme.h b/src/racket/include/scheme.h index 64fd793df0..90af06e77a 100644 --- a/src/racket/include/scheme.h +++ b/src/racket/include/scheme.h @@ -658,7 +658,7 @@ typedef struct Scheme_Offset_Cptr #define SCHEME_PRIM_OPT_MASK (1 | 2) #define SCHEME_PRIM_IS_PRIMITIVE 4 #define SCHEME_PRIM_IS_UNSAFE_OMITABLE 8 -#define SCHEME_PRIM_IS_STRUCT_OTHER 16 +#define SCHEME_PRIM_IS_OMITABLE 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 @@ -674,7 +674,7 @@ typedef struct Scheme_Offset_Cptr #define SCHEME_PRIM_OPT_NONCM 1 /* Values with SCHEME_PRIM_OTHER_TYPE_MASK */ -#define SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER 0 +#define SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER (32 | 256) #define SCHEME_PRIM_STRUCT_TYPE_CONSTR 128 #define SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER 256 #define SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER (128 | 256) diff --git a/src/racket/src/bool.c b/src/racket/src/bool.c index 9fcdf326f6..85589f8b64 100644 --- a/src/racket/src/bool.c +++ b/src/racket/src/bool.c @@ -83,20 +83,24 @@ void scheme_init_bool (Scheme_Env *env) p = scheme_make_folding_prim(not_prim, "not", 1, 1, 1); scheme_not_prim = p; - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_IS_OMITABLE); scheme_add_global_constant("not", p, env); p = scheme_make_folding_prim(boolean_p_prim, "boolean?", 1, 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_OMITABLE); scheme_add_global_constant("boolean?", p, env); p = scheme_make_folding_prim(eq_prim, "eq?", 2, 2, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_OMITABLE); scheme_eq_prim = p; scheme_add_global_constant("eq?", p, env); p = scheme_make_folding_prim(eqv_prim, "eqv?", 2, 2, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_OMITABLE); scheme_eqv_prim = p; scheme_add_global_constant("eqv?", scheme_eqv_prim, env); @@ -110,11 +114,13 @@ void scheme_init_bool (Scheme_Env *env) env); p = scheme_make_immed_prim(chaperone_p, "chaperone?", 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_OMITABLE); scheme_add_global_constant("chaperone?", p, env); p = scheme_make_immed_prim(impersonator_p, "impersonator?", 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_OMITABLE); scheme_add_global_constant("impersonator?", p, env); scheme_add_global_constant("chaperone-of?", diff --git a/src/racket/src/char.c b/src/racket/src/char.c index 7cd9b0a16c..369afa731a 100644 --- a/src/racket/src/char.c +++ b/src/racket/src/char.c @@ -97,7 +97,8 @@ void scheme_init_char (Scheme_Env *env) } p = scheme_make_folding_prim(char_p, "char?", 1, 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_OMITABLE); scheme_add_global_constant("char?", p, env); p = scheme_make_folding_prim(char_eq, "char=?", 2, -1, 1); diff --git a/src/racket/src/file.c b/src/racket/src/file.c index 771a3902e8..332665114d 100644 --- a/src/racket/src/file.c +++ b/src/racket/src/file.c @@ -317,7 +317,8 @@ void scheme_init_file(Scheme_Env *env) unix_symbol = scheme_intern_symbol("unix"); p = scheme_make_prim_w_arity(path_p, "path?", 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_OMITABLE); scheme_add_global_constant("path?", p, env); scheme_add_global_constant("path-for-some-system?", diff --git a/src/racket/src/fun.c b/src/racket/src/fun.c index 4c15dd1ba1..ccdc0c901c 100644 --- a/src/racket/src/fun.c +++ b/src/racket/src/fun.c @@ -236,7 +236,8 @@ scheme_init_fun (Scheme_Env *env) REGISTER_SO(scheme_procedure_arity_includes_proc); o = scheme_make_folding_prim(procedure_p, "procedure?", 1, 1, 1); - SCHEME_PRIM_PROC_FLAGS(o) |= SCHEME_PRIM_IS_UNARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(o) |= (SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_IS_OMITABLE); scheme_add_global_constant("procedure?", o, env); scheme_procedure_p_proc = o; @@ -284,7 +285,8 @@ scheme_init_fun (Scheme_Env *env) 0, -1); SCHEME_PRIM_PROC_FLAGS(scheme_values_func) |= (SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_IS_NARY_INLINED); + | SCHEME_PRIM_IS_NARY_INLINED + | SCHEME_PRIM_IS_OMITABLE); scheme_add_global_constant("values", scheme_values_func, env); @@ -436,12 +438,15 @@ scheme_init_fun (Scheme_Env *env) scheme_void_proc = scheme_make_folding_prim(void_func, "void", 0, -1, 1); + SCHEME_PRIM_PROC_FLAGS(scheme_void_proc) |= SCHEME_PRIM_IS_OMITABLE; scheme_add_global_constant("void", scheme_void_proc, env); - scheme_add_global_constant("void?", - scheme_make_folding_prim(void_p, - "void?", - 1, 1, 1), - env); + + + o = scheme_make_folding_prim(void_p, "void?", 1, 1, 1); + SCHEME_PRIM_PROC_FLAGS(o) |= (SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_IS_OMITABLE); + scheme_add_global_constant("void?", o, env); + #ifdef TIME_SYNTAX scheme_add_global_constant("time-apply", scheme_make_prim_w_arity2(time_apply, diff --git a/src/racket/src/jit.c b/src/racket/src/jit.c index c72358f6cb..5e93f8fe11 100644 --- a/src/racket/src/jit.c +++ b/src/racket/src/jit.c @@ -499,11 +499,9 @@ int scheme_is_noncm(Scheme_Object *a, mz_jit_state *jitter, int depth, int stack opts = ((Scheme_Prim_Proc_Header *)a)->flags & SCHEME_PRIM_OPT_MASK; 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_OTHER) { - if ((((Scheme_Prim_Proc_Header *)a)->flags & SCHEME_PRIM_OTHER_TYPE_MASK) - == SCHEME_PRIM_STRUCT_TYPE_PRED) - return 0; - } + if ((((Scheme_Prim_Proc_Header *)a)->flags & SCHEME_PRIM_OTHER_TYPE_MASK) + == SCHEME_PRIM_STRUCT_TYPE_PRED) + return 0; return 1; } } diff --git a/src/racket/src/jitinline.c b/src/racket/src/jitinline.c index 4cf7057baf..befcfc221f 100644 --- a/src/racket/src/jitinline.c +++ b/src/racket/src/jitinline.c @@ -120,25 +120,21 @@ 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_OTHER) { - int t = (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_OTHER_TYPE_MASK); - 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_STRUCT_TYPE_STRUCT_PROP_PRED) - return 6; - } + int t = (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_OTHER_TYPE_MASK); + 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_STRUCT_TYPE_STRUCT_PROP_PRED) + return 6; } else if (arity == 2) { - 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_STRUCT_TYPE_INDEXED_SETTER) - return 3; - else if (t == SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER) - return 5; - } + int t = (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_OTHER_TYPE_MASK); + if (t == SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER) + return 3; + else if (t == SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER) + return 5; } } return 0; @@ -536,6 +532,9 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in } else if (IS_NAMED_PRIM(rator, "null?")) { generate_inlined_constant_test(jitter, app, scheme_null, NULL, for_branch, branch_short, need_sync); return 1; + } else if (IS_NAMED_PRIM(rator, "void?")) { + generate_inlined_constant_test(jitter, app, scheme_void, NULL, for_branch, branch_short, need_sync); + return 1; } else if (IS_NAMED_PRIM(rator, "pair?")) { generate_inlined_type_test(jitter, app, scheme_pair_type, scheme_pair_type, 0, for_branch, branch_short, need_sync); return 1; diff --git a/src/racket/src/list.c b/src/racket/src/list.c index eac3539bda..16a7805151 100644 --- a/src/racket/src/list.c +++ b/src/racket/src/list.c @@ -177,17 +177,20 @@ scheme_init_list (Scheme_Env *env) scheme_add_global_constant ("null", scheme_null, env); p = scheme_make_folding_prim(pair_p_prim, "pair?", 1, 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_OMITABLE); scheme_add_global_constant ("pair?", p, env); p = scheme_make_folding_prim(mpair_p_prim, "mpair?", 1, 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_OMITABLE); scheme_add_global_constant ("mpair?", p, env); REGISTER_SO(scheme_cons_proc); p = scheme_make_immed_prim(cons_prim, "cons", 2, 2); scheme_cons_proc = p; - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_OMITABLE); scheme_add_global_constant ("cons", p, env); p = scheme_make_folding_prim(scheme_checked_car, "car", 1, 1, 1); @@ -201,7 +204,8 @@ scheme_init_list (Scheme_Env *env) REGISTER_SO(scheme_mcons_proc); p = scheme_make_immed_prim(mcons_prim, "mcons", 2, 2); scheme_mcons_proc = p; - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_OMITABLE); scheme_add_global_constant ("mcons", p, env); p = scheme_make_immed_prim(scheme_checked_mcar, "mcar", 1, 1); @@ -221,11 +225,13 @@ scheme_init_list (Scheme_Env *env) scheme_add_global_constant ("set-mcdr!", p, env); p = scheme_make_folding_prim(null_p_prim, "null?", 1, 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_OMITABLE); scheme_add_global_constant ("null?", p, env); p = scheme_make_folding_prim(list_p_prim, "list?", 1, 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_OMITABLE); scheme_add_global_constant ("list?", p, env); REGISTER_SO(scheme_list_proc); @@ -233,7 +239,8 @@ scheme_init_list (Scheme_Env *env) scheme_list_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_IS_NARY_INLINED); + | SCHEME_PRIM_IS_NARY_INLINED + | SCHEME_PRIM_IS_OMITABLE); scheme_add_global_constant ("list", p, env); REGISTER_SO(scheme_list_star_proc); @@ -241,7 +248,8 @@ scheme_init_list (Scheme_Env *env) scheme_list_star_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_IS_NARY_INLINED); + | SCHEME_PRIM_IS_NARY_INLINED + | SCHEME_PRIM_IS_OMITABLE); scheme_add_global_constant ("list*", p, env); scheme_add_global_constant("immutable?", @@ -419,17 +427,17 @@ scheme_init_list (Scheme_Env *env) REGISTER_SO(scheme_box_proc); p = scheme_make_immed_prim(box, BOX, 1, 1); scheme_box_proc = p; - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_IS_OMITABLE); scheme_add_global_constant(BOX, p, env); - scheme_add_global_constant("box-immutable", - scheme_make_immed_prim(immutable_box, - "box-immutable", - 1, 1), - env); + p = scheme_make_immed_prim(immutable_box, "box-immutable", 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_OMITABLE; + scheme_add_global_constant("box-immutable", p, env); p = scheme_make_folding_prim(box_p, BOXP, 1, 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_OMITABLE); scheme_add_global_constant(BOXP, p, env); p = scheme_make_noncm_prim(unbox, UNBOX, 1, 1); @@ -747,12 +755,14 @@ scheme_init_unsafe_list (Scheme_Env *env) p = scheme_make_immed_prim(unsafe_mcar, "unsafe-mcar", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_UNSAFE_OMITABLE); + | SCHEME_PRIM_IS_UNSAFE_OMITABLE + | SCHEME_PRIM_IS_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_IS_UNSAFE_OMITABLE); + | SCHEME_PRIM_IS_UNSAFE_OMITABLE + | SCHEME_PRIM_IS_OMITABLE); scheme_add_global_constant ("unsafe-mcdr", p, env); p = scheme_make_immed_prim(unsafe_set_mcar, "unsafe-set-mcar!", 2, 2); @@ -765,12 +775,14 @@ scheme_init_unsafe_list (Scheme_Env *env) p = scheme_make_immed_prim(unsafe_unbox, "unsafe-unbox", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_UNSAFE_OMITABLE); + | SCHEME_PRIM_IS_UNSAFE_OMITABLE + | SCHEME_PRIM_IS_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_IS_UNSAFE_OMITABLE); + | SCHEME_PRIM_IS_UNSAFE_OMITABLE + | SCHEME_PRIM_IS_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 635afef71c..76314ff00c 100644 --- a/src/racket/src/number.c +++ b/src/racket/src/number.c @@ -320,56 +320,61 @@ scheme_init_number (Scheme_Env *env) #endif p = scheme_make_folding_prim(number_p, "number?", 1, 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_OMITABLE); scheme_add_global_constant("number?", p, env); - scheme_add_global_constant("complex?", - scheme_make_folding_prim(complex_p, - "complex?", - 1, 1, 1), - env); + p = scheme_make_folding_prim(complex_p, "complex?", 1, 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_OMITABLE; + scheme_add_global_constant("complex?", p, env); p = scheme_make_folding_prim(real_p, "real?", 1, 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_OMITABLE); scheme_add_global_constant("real?", p, env); - scheme_add_global_constant("rational?", - scheme_make_folding_prim(rational_p, - "rational?", - 1, 1, 1), - env); - scheme_add_global_constant("integer?", - scheme_make_folding_prim(integer_p, - "integer?", - 1, 1, 1), - env); + + p = scheme_make_folding_prim(rational_p, "rational?", 1, 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_OMITABLE; + scheme_add_global_constant("rational?", p, env); + + p = scheme_make_folding_prim(integer_p, "integer?", 1, 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_OMITABLE; + scheme_add_global_constant("integer?", p, env); p = scheme_make_folding_prim(exact_integer_p, "exact-integer?", 1, 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_OMITABLE); scheme_add_global_constant("exact-integer?", p, env); p = scheme_make_folding_prim(exact_nonnegative_integer_p, "exact-nonnegative-integer?", 1, 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_OMITABLE); scheme_add_global_constant("exact-nonnegative-integer?", p, env); p = scheme_make_folding_prim(exact_positive_integer_p, "exact-positive-integer?", 1, 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_OMITABLE); scheme_add_global_constant("exact-positive-integer?", p, env); p = scheme_make_immed_prim(fixnum_p, "fixnum?", 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_OMITABLE); scheme_add_global_constant("fixnum?", p, env); p = scheme_make_folding_prim(inexact_real_p, "inexact-real?", 1, 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_OMITABLE); scheme_add_global_constant("inexact-real?", p, env); p = scheme_make_folding_prim(flonum_p, "flonum?", 1, 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_OMITABLE); scheme_add_global_constant("flonum?", p, env); p = scheme_make_folding_prim(single_flonum_p, "single-flonum?", 1, 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_OMITABLE); scheme_add_global_constant("single-flonum?", p, env); p = scheme_make_folding_prim(real_to_single_flonum, "real->single-flonum", 1, 1, 1); @@ -864,7 +869,8 @@ 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_OMITABLE; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNSAFE_OMITABLE + | SCHEME_PRIM_IS_OMITABLE); scheme_add_global_constant("unsafe-f64vector-ref", p, env); p = scheme_make_immed_prim(fl_set, "unsafe-f64vector-set!", @@ -887,7 +893,8 @@ 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_OMITABLE; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNSAFE_OMITABLE + | SCHEME_PRIM_IS_OMITABLE); scheme_add_global_constant("unsafe-flvector-ref", p, env); p = scheme_make_immed_prim(unsafe_flvector_set, "unsafe-flvector-set!", @@ -904,7 +911,8 @@ 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_OMITABLE); + | SCHEME_PRIM_IS_UNSAFE_OMITABLE + | SCHEME_PRIM_IS_OMITABLE); scheme_add_global_constant("unsafe-fxvector-ref", p, env); p = scheme_make_immed_prim(unsafe_fxvector_set, "unsafe-fxvector-set!", @@ -914,8 +922,9 @@ 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_OMITABLE; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_UNSAFE_OMITABLE + | SCHEME_PRIM_IS_OMITABLE); scheme_add_global_constant("unsafe-s16vector-ref", p, env); p = scheme_make_immed_prim(s16_set, "unsafe-s16vector-set!", @@ -925,8 +934,9 @@ 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_OMITABLE; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_UNSAFE_OMITABLE + | SCHEME_PRIM_IS_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 d7d1d57e21..0940ca9b5c 100644 --- a/src/racket/src/optimize.c +++ b/src/racket/src/optimize.c @@ -359,129 +359,73 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, } } } - /* (values ...) */ - if (SAME_OBJ(scheme_values_func, app->args[0])) { - note_match(app->num_args, vals, warn_info); - if ((app->num_args == vals) || (vals < 0)) { - int i; - for (i = app->num_args; i--; ) { - if (!scheme_omittable_expr(app->args[i + 1], 1, fuel - 1, resolved, warn_info, - deeper_than + (resolved ? app->num_args : 0))) - return 0; - } - return 1; - } - } - /* ({void,list,list*,vector,vector-immutable} ...) */ - if (SAME_OBJ(scheme_void_proc, app->args[0]) - || SAME_OBJ(scheme_list_proc, app->args[0]) - || SAME_OBJ(scheme_list_star_proc, app->args[0]) - || SAME_OBJ(scheme_vector_proc, app->args[0]) - || SAME_OBJ(scheme_vector_immutable_proc, app->args[0])) { - note_match(1, vals, warn_info); - if ((vals == 1) || (vals < 0)) { - int i; - for (i = app->num_args; i--; ) { - if (!scheme_omittable_expr(app->args[i + 1], 1, fuel - 1, resolved, warn_info, - deeper_than + (resolved ? app->num_args : 0))) - return 0; - } - return 1; - } - } - if (SCHEME_PRIMP(app->args[0]) - && (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); - if ((vals == 1) || (vals < 0)) { - /* can omit an unsafe op */ + + if (SCHEME_PRIMP(app->args[0])) { + if ((SCHEME_PRIM_PROC_FLAGS(app->args[0]) & SCHEME_PRIM_IS_OMITABLE) + && (app->num_args >= ((Scheme_Primitive_Proc *)app->args[0])->mina) + && (app->num_args <= ((Scheme_Primitive_Proc *)app->args[0])->mu.maxa) + && ((vals < 0) + || ((vals == 1) && !(SCHEME_PRIM_PROC_FLAGS(app->args[0]) & SCHEME_PRIM_IS_MULTI_RESULT)) + || (SAME_OBJ(scheme_values_func, app->args[0]) + && (vals == app->num_args)))) { int i; for (i = app->num_args; i--; ) { - if (!scheme_omittable_expr(app->args[i + 1], 1, fuel - 1, resolved, warn_info, + if (!scheme_omittable_expr(app->args[i + 1], 1, fuel - 1, resolved, warn_info, deeper_than + (resolved ? app->num_args : 0))) - return 0; - } + return 0; + } return 1; + } else if (!(SCHEME_PRIM_PROC_FLAGS(app->args[0]) & SCHEME_PRIM_IS_MULTI_RESULT)) { + note_match(1, vals, warn_info); + } else if (SAME_OBJ(scheme_values_func, app->args[0])) { + note_match(app->num_args, vals, warn_info); } } + return 0; } if (vtype == scheme_application2_type) { - /* ({values,void,list,list*,vector,vector-immutable,box} ) */ Scheme_App2_Rec *app = (Scheme_App2_Rec *)o; - if (SAME_OBJ(scheme_values_func, app->rator) - || SAME_OBJ(scheme_void_proc, app->rator) - || SAME_OBJ(scheme_list_proc, app->rator) - || SAME_OBJ(scheme_list_star_proc, app->rator) - || SAME_OBJ(scheme_vector_proc, app->rator) - || SAME_OBJ(scheme_vector_immutable_proc, app->rator) - || SAME_OBJ(scheme_box_proc, app->rator)) { - note_match(1, vals, warn_info); - if ((vals == 1) || (vals < 0)) { - if (scheme_omittable_expr(app->rand, 1, fuel - 1, resolved, warn_info, - deeper_than + (resolved ? 1 : 0))) - return 1; - } - } - if (SCHEME_PRIMP(app->rator) - && (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); - if ((vals == 1) || (vals < 0)) { + if (SCHEME_PRIMP(app->rator)) { + if ((SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_OMITABLE) + && (1 >= ((Scheme_Primitive_Proc *)app->rator)->mina) + && (1 <= ((Scheme_Primitive_Proc *)app->rator)->mu.maxa) + && ((vals < 0) + || ((vals == 1) && !(SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_MULTI_RESULT)) + || ((vals == 1) && SAME_OBJ(scheme_values_func, app->rator)))) { if (scheme_omittable_expr(app->rand, 1, fuel - 1, resolved, warn_info, deeper_than + (resolved ? 1 : 0))) return 1; + } else if (!(SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_MULTI_RESULT) + || SAME_OBJ(scheme_values_func, app->rator)) { + note_match(1, vals, warn_info); } } return 0; } if (vtype == scheme_application3_type) { - /* (values ) */ Scheme_App3_Rec *app = (Scheme_App3_Rec *)o; - if (SAME_OBJ(scheme_values_func, app->rator)) { - note_match(2, vals, warn_info); - if ((vals == 2) || (vals < 0)) { + if (SCHEME_PRIMP(app->rator)) { + if ((SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_OMITABLE) + && (2 >= ((Scheme_Primitive_Proc *)app->rator)->mina) + && (2 <= ((Scheme_Primitive_Proc *)app->rator)->mu.maxa) + && ((vals < 0) + || ((vals == 1) && !(SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_MULTI_RESULT)) + || ((vals == 2) && SAME_OBJ(scheme_values_func, app->rator)))) { if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, warn_info, deeper_than + (resolved ? 2 : 0)) && scheme_omittable_expr(app->rand2, 1, fuel - 1, resolved, warn_info, deeper_than + (resolved ? 2 : 0))) return 1; + } else if (!(SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_MULTI_RESULT)) { + note_match(1, vals, warn_info); + } else if (SAME_OBJ(scheme_values_func, app->rator)) { + note_match(2, vals, warn_info); } } - /* ({void,cons,list,list*,vector,vector-immutable) ) */ - if (SAME_OBJ(scheme_void_proc, app->rator) - || SAME_OBJ(scheme_cons_proc, app->rator) - || SAME_OBJ(scheme_mcons_proc, app->rator) - || SAME_OBJ(scheme_list_proc, app->rator) - || SAME_OBJ(scheme_list_star_proc, app->rator) - || SAME_OBJ(scheme_vector_proc, app->rator) - || SAME_OBJ(scheme_vector_immutable_proc, app->rator)) { - note_match(1, vals, warn_info); - if ((vals == 1) || (vals < 0)) { - if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, warn_info, - deeper_than + (resolved ? 2 : 0)) - && scheme_omittable_expr(app->rand2, 1, fuel - 1, resolved, warn_info, - deeper_than + (resolved ? 2 : 0))) - return 1; - } - } - if (SCHEME_PRIMP(app->rator) - && (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); - if ((vals == 1) || (vals < 0)) { - if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, warn_info, - deeper_than + (resolved ? 2 : 0)) - && scheme_omittable_expr(app->rand2, 1, fuel - 1, resolved, warn_info, - deeper_than + (resolved ? 2 : 0))) - return 1; - } - } + return 0; } return 0; @@ -1425,20 +1369,11 @@ static Scheme_Object *check_app_let_rator(Scheme_Object *app, Scheme_Object *rat static int is_nonmutating_primitive(Scheme_Object *rator, int n) { if (SCHEME_PRIMP(rator) - && (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_UNSAFE_NONMUTATING) + && (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_OMITABLE) && (n >= ((Scheme_Primitive_Proc *)rator)->mina) && (n <= ((Scheme_Primitive_Proc *)rator)->mu.maxa)) return 1; - if (SAME_OBJ(scheme_void_proc, rator) - || SAME_OBJ(scheme_list_proc, rator) - || (SAME_OBJ(scheme_cons_proc, rator) && (n == 2)) - || SAME_OBJ(scheme_list_star_proc, rator) - || SAME_OBJ(scheme_vector_proc, rator) - || SAME_OBJ(scheme_vector_immutable_proc, rator) - || (SAME_OBJ(scheme_box_proc, rator) && (n == 1))) - return 1; - return 0; } diff --git a/src/racket/src/portfun.c b/src/racket/src/portfun.c index bdf8ea2063..fed57b342d 100644 --- a/src/racket/src/portfun.c +++ b/src/racket/src/portfun.c @@ -316,7 +316,8 @@ scheme_init_port_fun(Scheme_Env *env) GLOBAL_NONCM_PRIM("port-count-lines!", port_count_lines, 1, 1, env); p = scheme_make_folding_prim(eof_object_p, "eof-object?", 1, 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_OMITABLE); scheme_add_global_constant("eof-object?", p, env); scheme_add_global_constant("write", scheme_write_proc, env); diff --git a/src/racket/src/print.c b/src/racket/src/print.c index c02adb2539..9bc9626b26 100644 --- a/src/racket/src/print.c +++ b/src/racket/src/print.c @@ -2377,10 +2377,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, cannot_print(pp, notdisplay, obj, ht, compact); else { 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; + kind = (((Scheme_Primitive_Proc *)(obj))->pp.flags & SCHEME_PRIM_OTHER_TYPE_MASK); if ((kind == SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER) || (kind == SCHEME_PRIM_STRUCT_TYPE_CONSTR) || (kind == SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER) diff --git a/src/racket/src/string.c b/src/racket/src/string.c index 08138a5f43..0ba631e70d 100644 --- a/src/racket/src/string.c +++ b/src/racket/src/string.c @@ -405,7 +405,8 @@ scheme_init_string (Scheme_Env *env) SCHEME_SET_CHAR_STRING_IMMUTABLE(banner_str); p = scheme_make_folding_prim(string_p, "string?", 1, 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_OMITABLE); scheme_add_global_constant("string?", p, env); scheme_add_global_constant("make-string", @@ -679,7 +680,8 @@ scheme_init_string (Scheme_Env *env) env); p = scheme_make_folding_prim(byte_string_p, "bytes?", 1, 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_NARY_INLINED + | SCHEME_PRIM_IS_OMITABLE); scheme_add_global_constant("bytes?", p, env); scheme_add_global_constant("make-bytes", diff --git a/src/racket/src/struct.c b/src/racket/src/struct.c index 99948fc6f7..9871da86e4 100644 --- a/src/racket/src/struct.c +++ b/src/racket/src/struct.c @@ -1154,8 +1154,7 @@ static Scheme_Object *make_struct_type_property_from_c(int argc, Scheme_Object * name[len+1] = 0; 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_STRUCT_TYPE_STRUCT_PROP_PRED); + ((Scheme_Closed_Primitive_Proc *)v)->pp.flags |= SCHEME_PRIM_STRUCT_TYPE_STRUCT_PROP_PRED; *predout = v; name = MALLOC_N_ATOMIC(char, len + 10); @@ -1163,8 +1162,7 @@ static Scheme_Object *make_struct_type_property_from_c(int argc, Scheme_Object * memcpy(name + len, "-accessor", 10); v = scheme_make_prim_closure_w_arity(prop_accessor, 1, a, name, 1, 2); - ((Scheme_Closed_Primitive_Proc *)v)->pp.flags |= (SCHEME_PRIM_IS_STRUCT_OTHER - | SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER); + ((Scheme_Closed_Primitive_Proc *)v)->pp.flags |= SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER; *accessout = v; @@ -3010,22 +3008,16 @@ int scheme_inspector_sees_part(Scheme_Object *s, Scheme_Object *insp, int pos) } -#define STRUCT_mPROCP(o, t, v) \ - (SCHEME_PRIMP(o) && ((((Scheme_Primitive_Proc *)o)->pp.flags & (t)) == (v))) - -#define STRUCT_PROCP(o, t) STRUCT_mPROCP(o, t, t) +#define STRUCT_mPROCP(o, v) \ + (SCHEME_PRIMP(o) && ((((Scheme_Primitive_Proc *)o)->pp.flags & SCHEME_PRIM_OTHER_TYPE_MASK) == (v))) static Scheme_Object * struct_setter_p(int argc, Scheme_Object *argv[]) { Scheme_Object *v = argv[0]; if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v); - return ((STRUCT_mPROCP(v, - SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_OTHER_TYPE_MASK, - SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER) - || STRUCT_mPROCP(v, - SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_OTHER_TYPE_MASK, - SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER)) + return ((STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER) + || STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER)) ? scheme_true : scheme_false); } @@ -3034,12 +3026,8 @@ struct_getter_p(int argc, Scheme_Object *argv[]) { Scheme_Object *v = argv[0]; if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v); - return ((STRUCT_mPROCP(v, - SCHEME_PRIM_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)) + return ((STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER) + || STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER)) ? scheme_true : scheme_false); } @@ -3048,9 +3036,7 @@ struct_pred_p(int argc, Scheme_Object *argv[]) { Scheme_Object *v = argv[0]; if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v); - return (STRUCT_mPROCP(v, - SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_OTHER_TYPE_MASK, - SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_TYPE_PRED) + return (STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_PRED) ? scheme_true : scheme_false); } @@ -3059,9 +3045,7 @@ struct_constr_p(int argc, Scheme_Object *argv[]) { Scheme_Object *v = argv[0]; if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v); - return (STRUCT_mPROCP(v, - SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_OTHER_TYPE_MASK, - SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_TYPE_CONSTR) + return (STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_CONSTR) ? scheme_true : scheme_false); } @@ -3070,9 +3054,7 @@ struct_prop_getter_p(int argc, Scheme_Object *argv[]) { Scheme_Object *v = argv[0]; if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v); - return ((STRUCT_mPROCP(v, - SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_OTHER_TYPE_MASK, - SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER) + return ((STRUCT_mPROCP(v, SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER) && SAME_TYPE(SCHEME_TYPE(SCHEME_PRIM_CLOSURE_ELS(v)[0]), scheme_struct_property_type)) ? scheme_true : scheme_false); } @@ -3082,9 +3064,7 @@ chaperone_prop_getter_p(int argc, Scheme_Object *argv[]) { Scheme_Object *v = argv[0]; if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v); - return ((STRUCT_mPROCP(v, - SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_OTHER_TYPE_MASK, - SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER) + return ((STRUCT_mPROCP(v, SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER) && SAME_TYPE(SCHEME_TYPE(SCHEME_PRIM_CLOSURE_ELS(v)[0]), scheme_chaperone_property_type)) ? scheme_true : scheme_false); } @@ -3102,11 +3082,9 @@ static Scheme_Object *make_struct_field_xxor(const char *who, int getter, /* We don't allow chaperones on the getter or setter procedure, because we can't preserve them in the generated procedure. */ - if (!STRUCT_mPROCP(argv[0], - SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_OTHER_TYPE_MASK, - SCHEME_PRIM_IS_STRUCT_OTHER | (getter - ? SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER - : SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER))) { + if (!STRUCT_mPROCP(argv[0], (getter + ? SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER + : SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER))) { scheme_wrong_type(who, (getter ? "accessor procedure that requires a field index" : "mutator procedure that requires a field index"), @@ -3779,14 +3757,14 @@ make_struct_proc(Scheme_Struct_Type *struct_type, struct_type->num_islots, struct_type->num_islots, 0); - flags |= SCHEME_PRIM_STRUCT_TYPE_CONSTR | SCHEME_PRIM_IS_STRUCT_OTHER; + flags |= SCHEME_PRIM_STRUCT_TYPE_CONSTR; } else if (proc_type == SCHEME_PRED) { a[0] = (Scheme_Object *)struct_type; p = scheme_make_folding_prim_closure(struct_pred, 1, a, func_name, 1, 1, 1); - flags |= SCHEME_PRIM_STRUCT_TYPE_PRED | SCHEME_PRIM_IS_STRUCT_OTHER; + flags |= SCHEME_PRIM_STRUCT_TYPE_PRED; } else { Struct_Proc_Info *i; int need_pos; @@ -3813,9 +3791,9 @@ make_struct_proc(Scheme_Struct_Type *struct_type, func_name, 1 + need_pos, 1 + need_pos, 0); if (need_pos) - flags |= SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER | SCHEME_PRIM_IS_STRUCT_OTHER; + flags |= SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER; else - flags |= SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER | SCHEME_PRIM_IS_STRUCT_OTHER; + flags |= SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER; /* Cache the accessor only if `struct_info' is used. This avoids keep lots of useless accessors. if (need_pos) struct_type->accessor = p; */ @@ -3825,9 +3803,9 @@ make_struct_proc(Scheme_Struct_Type *struct_type, func_name, 2 + need_pos, 2 + need_pos, 0); if (need_pos) - flags |= SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER | SCHEME_PRIM_IS_STRUCT_OTHER; + flags |= SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER; else - flags |= SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER | SCHEME_PRIM_IS_STRUCT_OTHER; + flags |= SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER; /* See note above: if (need_pos) struct_type->mutator = p; */ } @@ -3842,22 +3820,20 @@ Scheme_Object *scheme_rename_struct_proc(Scheme_Object *p, Scheme_Object *sym) { if (SCHEME_PRIMP(p)) { unsigned short flags = ((Scheme_Primitive_Proc *)p)->pp.flags; - 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); + 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; - - 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); - } + 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/symbol.c b/src/racket/src/symbol.c index 18da94fa27..2d264c6d56 100644 --- a/src/racket/src/symbol.c +++ b/src/racket/src/symbol.c @@ -324,7 +324,8 @@ scheme_init_symbol (Scheme_Env *env) Scheme_Object *p; p = scheme_make_folding_prim(symbol_p_prim, "symbol?", 1, 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_OMITABLE); scheme_add_global_constant("symbol?", p, env); p = scheme_make_folding_prim(symbol_unreadable_p_prim, "symbol-unreadable?", 1, 1, 1); diff --git a/src/racket/src/vector.c b/src/racket/src/vector.c index 86d39292f4..f8f2752d55 100644 --- a/src/racket/src/vector.c +++ b/src/racket/src/vector.c @@ -70,7 +70,8 @@ scheme_init_vector (Scheme_Env *env) Scheme_Object *p; p = scheme_make_folding_prim(vector_p, "vector?", 1, 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_OMITABLE); scheme_add_global_constant("vector?", p, env); scheme_add_global_constant("make-vector", @@ -84,7 +85,8 @@ scheme_init_vector (Scheme_Env *env) scheme_vector_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_IS_NARY_INLINED); + | SCHEME_PRIM_IS_NARY_INLINED + | SCHEME_PRIM_IS_OMITABLE); scheme_add_global_constant("vector", p, env); REGISTER_SO(scheme_vector_immutable_proc); @@ -92,7 +94,8 @@ scheme_init_vector (Scheme_Env *env) scheme_vector_immutable_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_IS_NARY_INLINED); + | SCHEME_PRIM_IS_NARY_INLINED + | SCHEME_PRIM_IS_OMITABLE); scheme_add_global_constant("vector-immutable", p, env); p = scheme_make_folding_prim(vector_length, "vector-length", 1, 1, 1); @@ -176,12 +179,14 @@ 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_OMITABLE); + | SCHEME_PRIM_IS_UNSAFE_OMITABLE + | SCHEME_PRIM_IS_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_OMITABLE); + | SCHEME_PRIM_IS_UNSAFE_OMITABLE + | SCHEME_PRIM_IS_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 +199,14 @@ 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_OMITABLE); + | SCHEME_PRIM_IS_UNSAFE_OMITABLE + | SCHEME_PRIM_IS_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_OMITABLE); + | SCHEME_PRIM_IS_UNSAFE_OMITABLE + | SCHEME_PRIM_IS_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 +224,8 @@ 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_OMITABLE); + | SCHEME_PRIM_IS_UNSAFE_OMITABLE + | SCHEME_PRIM_IS_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 +239,8 @@ 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_OMITABLE); + | SCHEME_PRIM_IS_UNSAFE_OMITABLE + | SCHEME_PRIM_IS_OMITABLE); scheme_add_global_constant("unsafe-bytes-ref", p, env); p = scheme_make_immed_prim(unsafe_bytes_set, "unsafe-bytes-set!", 3, 3);