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

clean up and generalize optimizer support for omittable primitives

Browse Source 
For example, the optimizer knew to drop `(cons x y)' if the result
is unused, but not `(pair? x)'.
This commit is contained in:
Matthew Flatt 2012-01-11 06:58:39 -07:00
parent 7850a26dfe
commit 8c092f093b
17 changed files with 278 additions and 271 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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

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

@ -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)

18
src/racket/src/bool.c
View File

@ -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?",

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

@ -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);

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

@ -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?",

19
src/racket/src/fun.c
View File

@ -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,

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

@ -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;
}
}

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

@ -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;

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

@ -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);

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

@ -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!",

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

@ -359,129 +359,73 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
}
}
}
/* (values <omittable> ...) */
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} <omittable> ...) */
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} <omittable>) */
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 <omittable> <omittable>) */
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) <omittable> <omittable>) */
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;
}

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

@ -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);

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

@ -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)

6
src/racket/src/string.c
View File

@ -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",

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

@ -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);
}
}

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

@ -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);

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

@ -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);