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

fix compiler confusion: non-mutating vs reorderable unsafe ops

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

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

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

@ -1372,6 +1372,67 @@
(require racket/bool) (require racket/bool)
(list #t))) (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 ;; Check bytecode verification of lifted functions

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

@ -657,10 +657,9 @@ typedef struct Scheme_Offset_Cptr
Do not use them directly. */ Do not use them directly. */
#define SCHEME_PRIM_OPT_MASK (1 | 2) #define SCHEME_PRIM_OPT_MASK (1 | 2)
#define SCHEME_PRIM_IS_PRIMITIVE 4 #define SCHEME_PRIM_IS_PRIMITIVE 4
#define SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER 8 #define SCHEME_PRIM_IS_UNSAFE_OMITABLE 8
#define SCHEME_PRIM_IS_STRUCT_PRED 16 #define SCHEME_PRIM_IS_STRUCT_OTHER 16
#define SCHEME_PRIM_IS_STRUCT_OTHER 32 #define SCHEME_PRIM_OTHER_TYPE_MASK (32 | 64 | 128 | 256)
#define SCHEME_PRIM_OTHER_TYPE_MASK (64 | 128 | 256)
#define SCHEME_PRIM_IS_MULTI_RESULT 512 #define SCHEME_PRIM_IS_MULTI_RESULT 512
#define SCHEME_PRIM_IS_BINARY_INLINED 1024 #define SCHEME_PRIM_IS_BINARY_INLINED 1024
#define SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL 2048 #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_PARAMETER 64
#define SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER (64 | 128) #define SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER (64 | 128)
#define SCHEME_PRIM_SOMETIMES_INLINED (64 | 256) #define SCHEME_PRIM_SOMETIMES_INLINED (64 | 256)
#define SCHEME_PRIM_TYPE_STRUCT_PROP_PRED (64 | 128 | 256) #define SCHEME_PRIM_STRUCT_TYPE_STRUCT_PROP_PRED (64 | 128 | 256)
#define SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER 32
#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_PRED (32 | 64)
#define SCHEME_PRIM_PROC_FLAGS(x) (((Scheme_Prim_Proc_Header *)x)->flags) #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_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_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_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_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) #define SCHEME_PRIM(obj) (((Scheme_Primitive_Proc *)(obj))->prim_val)

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

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

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

@ -1552,14 +1552,12 @@ static int common4(mz_jit_state *jitter, void *_data)
mz_patch_branch(ref); mz_patch_branch(ref);
(void)mz_bnei_t(refslow, JIT_R0, scheme_prim_type, JIT_R2); (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); 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);
jit_andi_i(JIT_R2, JIT_R2, SCHEME_PRIM_OTHER_TYPE_MASK); (void)jit_bnei_i(refslow, JIT_R2, ((kind == 3)
(void)jit_bnei_i(refslow, JIT_R2, SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER); ? SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER
} else { : ((kind == 1)
(void)jit_bmci_i(refslow, JIT_R2, ((kind == 1) ? SCHEME_PRIM_STRUCT_TYPE_PRED
? SCHEME_PRIM_IS_STRUCT_PRED : SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER)));
: SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER));
}
CHECK_LIMIT(); CHECK_LIMIT();
/* Check argument: */ /* Check argument: */
if (kind == 1) { if (kind == 1) {

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

@ -109,15 +109,15 @@ static int check_val_struct_prim(Scheme_Object *p, int arity)
{ {
if (p && SCHEME_PRIMP(p)) { if (p && SCHEME_PRIMP(p)) {
if (arity == 1) { if (arity == 1) {
if (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_PRED) if (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_OTHER) {
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) {
int t = (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_OTHER_TYPE_MASK); 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; return 4;
else if (t == SCHEME_PRIM_TYPE_STRUCT_PROP_PRED) else if (t == SCHEME_PRIM_STRUCT_TYPE_STRUCT_PROP_PRED)
return 6; return 6;
} }
} else if (arity == 2) { } else if (arity == 2) {

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

@ -746,11 +746,13 @@ scheme_init_unsafe_list (Scheme_Env *env)
scheme_add_global_constant ("unsafe-list-tail", p, env); scheme_add_global_constant ("unsafe-list-tail", p, env);
p = scheme_make_immed_prim(unsafe_mcar, "unsafe-mcar", 1, 1); 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); scheme_add_global_constant ("unsafe-mcar", p, env);
p = scheme_make_immed_prim(unsafe_mcdr, "unsafe-mcdr", 1, 1); 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); scheme_add_global_constant ("unsafe-mcdr", p, env);
p = scheme_make_immed_prim(unsafe_set_mcar, "unsafe-set-mcar!", 2, 2); 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); scheme_add_global_constant ("unsafe-set-mcdr!", p, env);
p = scheme_make_immed_prim(unsafe_unbox, "unsafe-unbox", 1, 1); 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); scheme_add_global_constant("unsafe-unbox", p, env);
p = scheme_make_immed_prim(unsafe_unbox_star, "unsafe-unbox*", 1, 1); 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); scheme_add_global_constant("unsafe-unbox*", p, env);
p = scheme_make_immed_prim(unsafe_set_box, "unsafe-set-box!", 2, 2); p = scheme_make_immed_prim(unsafe_set_box, "unsafe-set-box!", 2, 2);

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

@ -864,7 +864,7 @@ void scheme_init_unsafe_number(Scheme_Env *env)
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
else else
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_SOMETIMES_INLINED; 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); scheme_add_global_constant("unsafe-f64vector-ref", p, env);
p = scheme_make_immed_prim(fl_set, "unsafe-f64vector-set!", 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; SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
else else
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_SOMETIMES_INLINED; 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); scheme_add_global_constant("unsafe-flvector-ref", p, env);
p = scheme_make_immed_prim(unsafe_flvector_set, "unsafe-flvector-set!", 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", p = scheme_make_immed_prim(unsafe_fxvector_ref, "unsafe-fxvector-ref",
2, 2); 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED 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); scheme_add_global_constant("unsafe-fxvector-ref", p, env);
p = scheme_make_immed_prim(unsafe_fxvector_set, "unsafe-fxvector-set!", 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", p = scheme_make_immed_prim(s16_ref, "unsafe-s16vector-ref",
2, 2); 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; 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); scheme_add_global_constant("unsafe-s16vector-ref", p, env);
p = scheme_make_immed_prim(s16_set, "unsafe-s16vector-set!", 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", p = scheme_make_immed_prim(u16_ref, "unsafe-u16vector-ref",
2, 2); 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; 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); scheme_add_global_constant("unsafe-u16vector-ref", p, env);
p = scheme_make_immed_prim(u16_set, "unsafe-u16vector-set!", p = scheme_make_immed_prim(u16_set, "unsafe-u16vector-set!",

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

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

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

@ -2382,7 +2382,17 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
if (compact || !pp->print_unreadable) if (compact || !pp->print_unreadable)
cannot_print(pp, notdisplay, obj, ht, compact); cannot_print(pp, notdisplay, obj, ht, compact);
else { 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", print_named(obj, "struct-procedure",
((Scheme_Closed_Primitive_Proc *)obj)->name, ((Scheme_Closed_Primitive_Proc *)obj)->name,
-1, pp); -1, pp);

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

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

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

@ -176,12 +176,12 @@ scheme_init_unsafe_vector (Scheme_Env *env)
p = scheme_make_immed_prim(unsafe_vector_ref, "unsafe-vector-ref", 2, 2); 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_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); scheme_add_global_constant("unsafe-vector-ref", p, env);
p = scheme_make_immed_prim(unsafe_vector_star_ref, "unsafe-vector*-ref", 2, 2); 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_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); scheme_add_global_constant("unsafe-vector*-ref", p, env);
p = scheme_make_immed_prim(unsafe_vector_set, "unsafe-vector-set!", 3, 3); 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); 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_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); scheme_add_global_constant("unsafe-struct-ref", p, env);
p = scheme_make_immed_prim(unsafe_struct_star_ref, "unsafe-struct*-ref", 2, 2); 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_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); scheme_add_global_constant("unsafe-struct*-ref", p, env);
p = scheme_make_immed_prim(unsafe_struct_set, "unsafe-struct-set!", 3, 3); 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); 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_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); scheme_add_global_constant("unsafe-string-ref", p, env);
p = scheme_make_immed_prim(unsafe_string_set, "unsafe-string-set!", 3, 3); p = scheme_make_immed_prim(unsafe_string_set, "unsafe-string-set!", 3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED; 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); p = scheme_make_immed_prim(unsafe_bytes_len, "unsafe-bytes-length", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED 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); 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_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); scheme_add_global_constant("unsafe-bytes-ref", p, env);
p = scheme_make_immed_prim(unsafe_bytes_set, "unsafe-bytes-set!", 3, 3); p = scheme_make_immed_prim(unsafe_bytes_set, "unsafe-bytes-set!", 3, 3);