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

fix compiler to not move allocation across continuation capture

Browse Source 
Note that even the movement of operations like `unsafe-fl+` is
constrained, since the operation can allocate. For example, a
continuation captured in

    (let ([a (unsafe-fl+ x y)])
      (call-with-composable-continuation ....)
      a)

should return an `eq?` result. The compiler must not only refrain from
moving the `unsafe-fl+` call, it must not mark `a` as a flonum
binding, because that would cause the JIT to delay allocation of `a`
until the return site.
This commit is contained in:
Matthew Flatt 2014-03-11 10:48:51 -06:00
parent 30959e86aa
commit 389aa9fcd8
9 changed files with 284 additions and 109 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

100
pkgs/racket-pkgs/racket-test/tests/racket/optimize.rktl
View File

@ -1031,10 +1031,11 @@
(error "bad") (error "bad")
(equal? (list* w z) (list* z w)))) (equal? (list* w z) (list* z w))))
;; Ok to move `box' past a side effect: ;; Ok to move `box' past a side effect (that can't capture a
;; resumable continuation):
(test-comp '(let ([h (box 0.0)]) (test-comp '(let ([h (box 0.0)])
(list (printf "hi\n") h)) (list (random) h))
'(list (printf "hi\n") (box 0.0))) '(list (random) (box 0.0)))
;; Don't move `box' past a `lambda': ;; Don't move `box' past a `lambda':
(test-comp '(let ([h (box 0.0)]) (test-comp '(let ([h (box 0.0)])
@ -1394,6 +1395,19 @@
[(p) (q)]) [(p) (q)])
(list x y z)))) (list x y z))))
(test-comp '(lambda (f a)
(letrec ([y (if (zero? a)
(error "no")
8)]
[f (lambda (x) (f x))])
f))
'(lambda (f a)
(let ([y (if (zero? a)
(error "no")
8)])
(letrec ([f (lambda (x) (f x))])
f))))
(test-comp '(procedure? add1) (test-comp '(procedure? add1)
#t) #t)
(test-comp '(procedure? (lambda (x) x)) (test-comp '(procedure? (lambda (x) x))
@ -1586,14 +1600,18 @@
(test-bin 'eq?) (test-bin 'eq?)
(test-bin 'eqv?)) (test-bin 'eqv?))
(let ([test-move (for ([middle (in-list (list '(random) ; known immediate
(lambda (expr [same? #t]) '(read)))] ; could capture continuation?
[default-same? (in-list (list #t
#f))])
(let ([test-move
(lambda (expr [same? default-same?])
(test-comp `(lambda (z) (test-comp `(lambda (z)
(let ([x ,expr]) (let ([x ,expr])
(let ([y (read)]) (let ([y ,middle])
(list y x)))) (list y x))))
`(lambda (z) `(lambda (z)
(list (read) ,expr)) (list ,middle ,expr))
same?))]) same?))])
(test-move '(cons 1 2)) (test-move '(cons 1 2))
(test-move '(mcons 1 2)) (test-move '(mcons 1 2))
@ -1610,7 +1628,32 @@
(test-move '(cons 1 2 3) #f) (test-move '(cons 1 2 3) #f)
(test-move '(mcons 1 2 3) #f) (test-move '(mcons 1 2 3) #f)
(test-move '(box 1 2) #f) (test-move '(box 1 2) #f)
(test-move '(box-immutable 1 2) #f)) (test-move '(box-immutable 1 2) #f)))
;; Check move in to `else` branch where `then`
;; branch might capture a continuation
(test-comp `(lambda (z)
(let ([x (cons 1 2)])
(if z
(read)
x)))
`(lambda (z)
(if z
(read)
(cons 1 2))))
;; But not after the merge:
(test-comp `(lambda (z)
(let ([x (cons 1 2)])
(if z
(read)
(void))
x))
`(lambda (z)
(if z
(read)
(void))
(cons 1 2))
#f)
(let ([test-use-unsafe (let ([test-use-unsafe
(lambda (pred op unsafe-op) (lambda (pred op unsafe-op)
@ -1711,13 +1754,22 @@
(unsafe-car x)) (unsafe-car x))
#f) #f)
;; it's ok to delay `list', because there's no space-safety issue ;; It would be ok to delay `list', because there's no space-safety issue
;; ... except that an arbitrary function might capture a continuation:
(test-comp '(lambda (f x) (test-comp '(lambda (f x)
(let ([y (list x)]) (let ([y (list x)])
(f) (f)
y)) y))
'(lambda (f x) '(lambda (f x)
(f) (f)
(list x))
#f)
(test-comp '(lambda (f x)
(let ([y (list x)])
(random)
y))
'(lambda (f x)
(random)
(list x))) (list x)))
;; don't duplicate formerly once-used variable due to inlining ;; don't duplicate formerly once-used variable due to inlining
@ -3294,6 +3346,36 @@
(test '(0.5e7 yep) (lambda () (even 1e7 0.0)))) (test '(0.5e7 yep) (lambda () (even 1e7 0.0))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Double-check that allocation is not moved
;; across continuation capture:
(let ()
(define g #f)
(define p (make-continuation-prompt-tag))
(define (t)
(let ([a (cons 1 2)])
(call-with-composable-continuation (λ (k) (set! g k)) p)
a))
(call-with-continuation-prompt t p)
(test #t eq?
(call-with-continuation-prompt g p)
(call-with-continuation-prompt g p)))
(let ()
(define g #f)
(define p (make-continuation-prompt-tag))
(define (t)
(let ([a (fl+ (random) 1.0)])
(call-with-composable-continuation (λ (k) (set! g k)) p)
(if (fl= a 0.0) ; encourage unboxing of `a` (if not for the continuation capture)
#f
a))) ; must not delay flnonum allocation to here
(call-with-continuation-prompt t p)
(test #t eq?
(call-with-continuation-prompt g p)
(call-with-continuation-prompt g p)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs) (report-errs)

10
racket/src/racket/src/cstartup.inc
View File

@ -1,5 +1,5 @@
{ {
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,48,46,51,84,0,0,0,0,0,0,0,0,0,0, SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,48,46,52,84,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,51,0,0,0,1,0,0,10,0,14,0, 0,0,0,0,0,0,0,0,0,0,51,0,0,0,1,0,0,10,0,14,0,
19,0,32,0,37,0,40,0,47,0,54,0,59,0,63,0,67,0,74,0,83, 19,0,32,0,37,0,40,0,47,0,54,0,59,0,63,0,67,0,74,0,83,
0,87,0,93,0,107,0,121,0,124,0,130,0,134,0,136,0,147,0,149,0, 0,87,0,93,0,107,0,121,0,124,0,130,0,134,0,136,0,147,0,149,0,
@ -100,7 +100,7 @@
EVAL_ONE_SIZED_STR((char *)expr, 2051); EVAL_ONE_SIZED_STR((char *)expr, 2051);
} }
{ {
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,48,46,51,84,0,0,0,0,0,0,0,0,0,0, SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,48,46,52,84,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,187,0,0,0,1,0,0,8,0,21,0, 0,0,0,0,0,0,0,0,0,0,187,0,0,0,1,0,0,8,0,21,0,
26,0,43,0,55,0,77,0,106,0,150,0,156,0,165,0,172,0,187,0,205, 26,0,43,0,55,0,77,0,106,0,150,0,156,0,165,0,172,0,187,0,205,
0,217,0,233,0,247,0,13,1,32,1,39,1,73,1,90,1,107,1,130,1, 0,217,0,233,0,247,0,13,1,32,1,39,1,73,1,90,1,107,1,130,1,
@ -1017,7 +1017,7 @@
EVAL_ONE_SIZED_STR((char *)expr, 19187); EVAL_ONE_SIZED_STR((char *)expr, 19187);
} }
{ {
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,48,46,51,84,0,0,0,0,0,0,0,0,0,0, SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,48,46,52,84,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,14,0,0,0,1,0,0,15,0,40,0, 0,0,0,0,0,0,0,0,0,0,14,0,0,0,1,0,0,15,0,40,0,
57,0,75,0,97,0,120,0,140,0,162,0,171,0,180,0,187,0,196,0,203, 57,0,75,0,97,0,120,0,140,0,162,0,171,0,180,0,187,0,196,0,203,
0,0,0,231,1,0,0,74,35,37,112,108,97,99,101,45,115,116,114,117,99, 0,0,0,231,1,0,0,74,35,37,112,108,97,99,101,45,115,116,114,117,99,
@ -1047,7 +1047,7 @@
EVAL_ONE_SIZED_STR((char *)expr, 557); EVAL_ONE_SIZED_STR((char *)expr, 557);
} }
{ {
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,48,46,51,84,0,0,0,0,0,0,0,0,0,0, SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,48,46,52,84,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,106,0,0,0,1,0,0,7,0,18,0, 0,0,0,0,0,0,0,0,0,0,106,0,0,0,1,0,0,7,0,18,0,
45,0,51,0,60,0,67,0,89,0,102,0,128,0,145,0,167,0,175,0,187, 45,0,51,0,60,0,67,0,89,0,102,0,128,0,145,0,167,0,175,0,187,
0,202,0,218,0,236,0,0,1,12,1,28,1,51,1,75,1,87,1,118,1, 0,202,0,218,0,236,0,0,1,12,1,28,1,51,1,75,1,87,1,118,1,
@ -1529,7 +1529,7 @@
EVAL_ONE_SIZED_STR((char *)expr, 10046); EVAL_ONE_SIZED_STR((char *)expr, 10046);
} }
{ {
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,48,46,51,84,0,0,0,0,0,0,0,0,0,0, SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,48,46,52,84,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,11,0,0,0,1,0,0,10,0,16,0, 0,0,0,0,0,0,0,0,0,0,11,0,0,0,1,0,0,10,0,16,0,
29,0,44,0,58,0,78,0,90,0,104,0,118,0,170,0,0,0,101,1,0, 29,0,44,0,58,0,78,0,90,0,104,0,118,0,170,0,0,0,101,1,0,
0,69,35,37,98,117,105,108,116,105,110,65,113,117,111,116,101,29,94,2,2, 0,69,35,37,98,117,105,108,116,105,110,65,113,117,111,116,101,29,94,2,2,

25
racket/src/racket/src/error.c
View File

@ -684,8 +684,15 @@ static intptr_t scheme_sprintf(char *s, intptr_t maxlen, const char *msg, ...)
return len; return len;
} }
#define ESCAPING_NONCM_PRIM(name, func, a1, a2, env) \
p = scheme_make_noncm_prim(func, name, a1, a2); \
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_ALWAYS_ESCAPES); \
scheme_add_global_constant(name, p, env);
void scheme_init_error(Scheme_Env *env) void scheme_init_error(Scheme_Env *env)
{ {
Scheme_Object *p;
if (!scheme_console_printf) if (!scheme_console_printf)
scheme_console_printf = default_printf; scheme_console_printf = default_printf;
if (!scheme_console_output) if (!scheme_console_output)
@ -694,15 +701,15 @@ void scheme_init_error(Scheme_Env *env)
REGISTER_SO(scheme_raise_arity_error_proc); REGISTER_SO(scheme_raise_arity_error_proc);
/* errors */ /* errors */
GLOBAL_NONCM_PRIM("error", error, 1, -1, env); ESCAPING_NONCM_PRIM("error", error, 1, -1, env);
GLOBAL_NONCM_PRIM("raise-user-error", raise_user_error, 1, -1, env); ESCAPING_NONCM_PRIM("raise-user-error", raise_user_error, 1, -1, env);
GLOBAL_NONCM_PRIM("raise-syntax-error", raise_syntax_error, 2, 5, env); ESCAPING_NONCM_PRIM("raise-syntax-error", raise_syntax_error, 2, 5, env);
GLOBAL_NONCM_PRIM("raise-type-error", raise_type_error, 3, -1, env); ESCAPING_NONCM_PRIM("raise-type-error", raise_type_error, 3, -1, env);
GLOBAL_NONCM_PRIM("raise-argument-error", raise_argument_error, 3, -1, env); ESCAPING_NONCM_PRIM("raise-argument-error", raise_argument_error, 3, -1, env);
GLOBAL_NONCM_PRIM("raise-result-error", raise_result_error, 3, -1, env); ESCAPING_NONCM_PRIM("raise-result-error", raise_result_error, 3, -1, env);
GLOBAL_NONCM_PRIM("raise-arguments-error", raise_arguments_error, 2, -1, env); ESCAPING_NONCM_PRIM("raise-arguments-error", raise_arguments_error, 2, -1, env);
GLOBAL_NONCM_PRIM("raise-mismatch-error", raise_mismatch_error, 3, -1, env); ESCAPING_NONCM_PRIM("raise-mismatch-error", raise_mismatch_error, 3, -1, env);
GLOBAL_NONCM_PRIM("raise-range-error", raise_range_error, 7, 8, env); ESCAPING_NONCM_PRIM("raise-range-error", raise_range_error, 7, 8, env);
scheme_raise_arity_error_proc = scheme_make_noncm_prim(raise_arity_error, "raise-arity-error", 2, -1); scheme_raise_arity_error_proc = scheme_make_noncm_prim(raise_arity_error, "raise-arity-error", 2, -1);
scheme_add_global_constant("raise-arity-error", scheme_raise_arity_error_proc, env); scheme_add_global_constant("raise-arity-error", scheme_raise_arity_error_proc, env);

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

@ -771,19 +771,6 @@ scheme_make_prim_w_arity(Scheme_Prim *fun, const char *name,
0, 0, NULL); 0, 0, NULL);
} }
Scheme_Object *
scheme_make_folding_prim(Scheme_Prim *fun, const char *name,
mzshort mina, mzshort maxa,
short folding)
{
return make_prim_closure(fun, 1, name, mina, maxa,
(folding
? SCHEME_PRIM_OPT_FOLDING
: 0),
1, 1,
0, 0, NULL);
}
Scheme_Object * Scheme_Object *
scheme_make_noncm_prim(Scheme_Prim *fun, const char *name, scheme_make_noncm_prim(Scheme_Prim *fun, const char *name,
mzshort mina, mzshort maxa) mzshort mina, mzshort maxa)
@ -802,14 +789,30 @@ scheme_make_immed_prim(Scheme_Prim *fun, const char *name,
mzshort mina, mzshort maxa) mzshort mina, mzshort maxa)
{ {
/* An immediate primitive is a non-cm primitive, and it doesn't /* An immediate primitive is a non-cm primitive, and it doesn't
extend the continuation in a way that interacts with space safety, except capture a continuation or extend the continuation in a way that
maybe to raise an exception. */ interacts with space safety (which implies no interposition via
chaperones), except maybe to raise an exception. */
return make_prim_closure(fun, 1, name, mina, maxa, return make_prim_closure(fun, 1, name, mina, maxa,
SCHEME_PRIM_OPT_IMMEDIATE, SCHEME_PRIM_OPT_IMMEDIATE,
1, 1, 1, 1,
0, 0, NULL); 0, 0, NULL);
} }
Scheme_Object *
scheme_make_folding_prim(Scheme_Prim *fun, const char *name,
mzshort mina, mzshort maxa,
short folding)
{
/* A folding primitive is an immediate primitive, and for constant
arguments the result must be the same on all runs and platforms. */
return make_prim_closure(fun, 1, name, mina, maxa,
(folding
? SCHEME_PRIM_OPT_FOLDING
: 0),
1, 1,
0, 0, NULL);
}
Scheme_Object * Scheme_Object *
scheme_make_noneternal_prim_w_arity(Scheme_Prim *fun, const char *name, scheme_make_noneternal_prim_w_arity(Scheme_Prim *fun, const char *name,
mzshort mina, mzshort maxa) mzshort mina, mzshort maxa)

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

@ -768,25 +768,29 @@ scheme_init_unsafe_list (Scheme_Env *env)
REGISTER_SO(scheme_unsafe_car_proc); REGISTER_SO(scheme_unsafe_car_proc);
p = scheme_make_folding_prim(unsafe_car, "unsafe-car", 1, 1, 1); p = scheme_make_folding_prim(unsafe_car, "unsafe-car", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_IS_UNSAFE_NONALLOCATE);
scheme_add_global_constant ("unsafe-car", p, env); scheme_add_global_constant ("unsafe-car", p, env);
scheme_unsafe_car_proc = p; scheme_unsafe_car_proc = p;
REGISTER_SO(scheme_unsafe_cdr_proc); REGISTER_SO(scheme_unsafe_cdr_proc);
p = scheme_make_folding_prim(unsafe_cdr, "unsafe-cdr", 1, 1, 1); p = scheme_make_folding_prim(unsafe_cdr, "unsafe-cdr", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_IS_UNSAFE_NONALLOCATE);
scheme_add_global_constant ("unsafe-cdr", p, env); scheme_add_global_constant ("unsafe-cdr", p, env);
scheme_unsafe_cdr_proc = p; scheme_unsafe_cdr_proc = p;
p = scheme_make_folding_prim(unsafe_list_ref, "unsafe-list-ref", 2, 2, 1); p = scheme_make_folding_prim(unsafe_list_ref, "unsafe-list-ref", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_IS_UNSAFE_NONALLOCATE);
scheme_add_global_constant ("unsafe-list-ref", p, env); scheme_add_global_constant ("unsafe-list-ref", p, env);
p = scheme_make_folding_prim(unsafe_list_tail, "unsafe-list-tail", 2, 2, 1); p = scheme_make_folding_prim(unsafe_list_tail, "unsafe-list-tail", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_IS_UNSAFE_NONALLOCATE);
scheme_add_global_constant ("unsafe-list-tail", p, env); scheme_add_global_constant ("unsafe-list-tail", p, env);
REGISTER_SO(scheme_unsafe_mcar_proc); REGISTER_SO(scheme_unsafe_mcar_proc);

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

@ -53,9 +53,13 @@ struct Optimize_Info
int original_frame, new_frame; int original_frame, new_frame;
Scheme_Object *consts; Scheme_Object *consts;
Comp_Prefix *cp; Comp_Prefix *cp;
int init_kclock;
/* Propagated up and down the chain: */ /* Propagated up and down the chain: */
int size, vclock, psize; int size;
int vclock; /* virtual clock that ticks for a side effect */
int kclock; /* virtual clock that ticks for a potential continuation capture */
int psize;
short inline_fuel; short inline_fuel;
char letrec_not_twice, enforce_const, use_psize, has_nonleaf; char letrec_not_twice, enforce_const, use_psize, has_nonleaf;
Scheme_Hash_Table *top_level_consts; Scheme_Hash_Table *top_level_consts;
@ -78,6 +82,7 @@ struct Optimize_Info
}; };
#define OPT_IS_MUTATED 0x1 #define OPT_IS_MUTATED 0x1
#define OPT_ESCAPES_AFTER_K_TICK 0x2
#define OPT_LOCAL_TYPE_ARG_SHIFT 2 #define OPT_LOCAL_TYPE_ARG_SHIFT 2
#define OPT_LOCAL_TYPE_VAL_SHIFT (OPT_LOCAL_TYPE_ARG_SHIFT + SCHEME_MAX_LOCAL_TYPE_BITS) #define OPT_LOCAL_TYPE_VAL_SHIFT (OPT_LOCAL_TYPE_ARG_SHIFT + SCHEME_MAX_LOCAL_TYPE_BITS)
@ -103,10 +108,12 @@ static void add_type(Optimize_Info *info, int pos, Scheme_Object *pred);
static void optimize_mutated(Optimize_Info *info, int pos); static void optimize_mutated(Optimize_Info *info, int pos);
static void optimize_produces_local_type(Optimize_Info *info, int pos, int ct); static void optimize_produces_local_type(Optimize_Info *info, int pos, int ct);
static int produces_local_type(Scheme_Object *rator, int argc);
static Scheme_Object *optimize_reverse(Optimize_Info *info, int pos, int unless_mutated, int disrupt_single_use); static Scheme_Object *optimize_reverse(Optimize_Info *info, int pos, int unless_mutated, int disrupt_single_use);
static int optimize_is_used(Optimize_Info *info, int pos); static int optimize_is_used(Optimize_Info *info, int pos);
static int optimize_any_uses(Optimize_Info *info, int start_pos, int end_pos); static int optimize_any_uses(Optimize_Info *info, int start_pos, int end_pos);
static int optimize_is_mutated(Optimize_Info *info, int pos); static int optimize_is_mutated(Optimize_Info *info, int pos);
static int optimize_escapes_after_k_tick(Optimize_Info *info, int pos);
static int optimize_is_local_type_arg(Optimize_Info *info, int pos, int depth); static int optimize_is_local_type_arg(Optimize_Info *info, int pos, int depth);
static int optimize_is_local_type_valued(Optimize_Info *info, int pos); static int optimize_is_local_type_valued(Optimize_Info *info, int pos);
static int env_uses_toplevel(Optimize_Info *frame); static int env_uses_toplevel(Optimize_Info *frame);
@ -132,6 +139,7 @@ typedef struct Scheme_Once_Used {
Scheme_Object *expr; Scheme_Object *expr;
int pos; int pos;
int vclock; int vclock;
int kclock;
int used; int used;
int delta; int delta;
@ -141,7 +149,7 @@ typedef struct Scheme_Once_Used {
struct Scheme_Once_Used *next; struct Scheme_Once_Used *next;
} Scheme_Once_Used; } Scheme_Once_Used;
static Scheme_Once_Used *make_once_used(Scheme_Object *val, int pos, int vclock, Scheme_Once_Used *prev); static Scheme_Once_Used *make_once_used(Scheme_Object *val, int pos, int vclock, int kclock, Scheme_Once_Used *prev);
#ifdef MZ_PRECISE_GC #ifdef MZ_PRECISE_GC
static void register_traversers(void); static void register_traversers(void);
@ -931,7 +939,7 @@ static int single_valued_noncm_expression(Scheme_Object *expr, int fuel)
return 0; return 0;
} }
static int is_movable_prim(Scheme_Object *rator, int n, int cross_lambda) static int is_movable_prim(Scheme_Object *rator, int n, int cross_lambda, int cross_k, Optimize_Info *info)
/* A -1 return means that the arguments must be movable without /* A -1 return means that the arguments must be movable without
changing space complexity. */ changing space complexity. */
{ {
@ -941,6 +949,11 @@ static int is_movable_prim(Scheme_Object *rator, int n, int cross_lambda)
doing so risks duplicating a computation if the relevant `lambda' doing so risks duplicating a computation if the relevant `lambda'
is later inlined. */ is later inlined. */
if (cross_lambda) return 0; if (cross_lambda) return 0;
if (cross_k
&& !(SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_IS_UNSAFE_NONALLOCATE)
&& (produces_local_type(rator, n) != SCHEME_LOCAL_TYPE_FIXNUM)) {
return 0;
}
return -1; return -1;
} }
} }
@ -949,6 +962,7 @@ static int is_movable_prim(Scheme_Object *rator, int n, int cross_lambda)
return -1; return -1;
if (!cross_lambda if (!cross_lambda
&& !cross_k /* because all calls below allocate */
/* Note that none of these have space-safety issues, since they /* Note that none of these have space-safety issues, since they
return values that contain all arguments: */ return values that contain all arguments: */
&& (SAME_OBJ(scheme_list_proc, rator) && (SAME_OBJ(scheme_list_proc, rator)
@ -965,7 +979,8 @@ static int is_movable_prim(Scheme_Object *rator, int n, int cross_lambda)
return 0; return 0;
} }
static int movable_expression(Scheme_Object *expr, Optimize_Info *info, int delta, int cross_lambda, static int movable_expression(Scheme_Object *expr, Optimize_Info *info, int delta,
int cross_lambda, int cross_k,
int check_space, int fuel) int check_space, int fuel)
/* An expression that can't necessarily be constant-folded, /* An expression that can't necessarily be constant-folded,
but can be delayed because it has no side-effects (or is unsafe); but can be delayed because it has no side-effects (or is unsafe);
@ -999,11 +1014,12 @@ static int movable_expression(Scheme_Object *expr, Optimize_Info *info, int delt
} }
break; break;
case scheme_application_type: case scheme_application_type:
can_move = is_movable_prim(((Scheme_App_Rec *)expr)->args[0], ((Scheme_App_Rec *)expr)->num_args, cross_lambda); can_move = is_movable_prim(((Scheme_App_Rec *)expr)->args[0], ((Scheme_App_Rec *)expr)->num_args,
cross_lambda, cross_k, info);
if (can_move) { if (can_move) {
int i; int i;
for (i = ((Scheme_App_Rec *)expr)->num_args; i--; ) { for (i = ((Scheme_App_Rec *)expr)->num_args; i--; ) {
if (!movable_expression(((Scheme_App_Rec *)expr)->args[i+1], info, delta, cross_lambda, if (!movable_expression(((Scheme_App_Rec *)expr)->args[i+1], info, delta, cross_lambda, cross_k,
check_space || (can_move < 0), fuel - 1)) check_space || (can_move < 0), fuel - 1))
return 0; return 0;
} }
@ -1011,19 +1027,19 @@ static int movable_expression(Scheme_Object *expr, Optimize_Info *info, int delt
} }
break; break;
case scheme_application2_type: case scheme_application2_type:
can_move = is_movable_prim(((Scheme_App2_Rec *)expr)->rator, 1, cross_lambda); can_move = is_movable_prim(((Scheme_App2_Rec *)expr)->rator, 1, cross_lambda, cross_k, info);
if (can_move) { if (can_move) {
if (movable_expression(((Scheme_App2_Rec *)expr)->rand, info, delta, cross_lambda, if (movable_expression(((Scheme_App2_Rec *)expr)->rand, info, delta, cross_lambda, cross_k,
check_space || (can_move < 0), fuel - 1)) check_space || (can_move < 0), fuel - 1))
return 1; return 1;
} }
break; break;
case scheme_application3_type: case scheme_application3_type:
can_move = is_movable_prim(((Scheme_App3_Rec *)expr)->rator, 2, cross_lambda); can_move = is_movable_prim(((Scheme_App3_Rec *)expr)->rator, 2, cross_lambda, cross_k, info);
if (can_move) { if (can_move) {
if (movable_expression(((Scheme_App3_Rec *)expr)->rand1, info, delta, cross_lambda, if (movable_expression(((Scheme_App3_Rec *)expr)->rand1, info, delta, cross_lambda, cross_k,
check_space || (can_move < 0), fuel - 1) check_space || (can_move < 0), fuel - 1)
&& movable_expression(((Scheme_App3_Rec *)expr)->rand2, info, delta, cross_lambda, && movable_expression(((Scheme_App3_Rec *)expr)->rand2, info, delta, cross_lambda, cross_k,
check_space || (can_move < 0), fuel - 1)) check_space || (can_move < 0), fuel - 1))
return 1; return 1;
} }
@ -1527,6 +1543,7 @@ Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int a
if (nested_count) { if (nested_count) {
sub_info = optimize_info_add_frame(info, nested_count, nested_count, 0); sub_info = optimize_info_add_frame(info, nested_count, nested_count, 0);
sub_info->vclock++; sub_info->vclock++;
sub_info->kclock++;
/* We could propagate bound values in sub_info, but relevant inlining /* We could propagate bound values in sub_info, but relevant inlining
and propagatation has probably already happened when the rator was and propagatation has probably already happened when the rator was
optimized. */ optimized. */
@ -1876,6 +1893,24 @@ static int is_nonmutating_primitive(Scheme_Object *rator, int n)
return 0; return 0;
} }
static int is_noncapturing_primitive(Scheme_Object *rator, int n)
{
if (SCHEME_PRIMP(rator)) {
int opt;
opt = ((Scheme_Prim_Proc_Header *)rator)->flags & SCHEME_PRIM_OPT_MASK;
if (opt >= SCHEME_PRIM_OPT_IMMEDIATE)
return 1;
if (opt >= SCHEME_PRIM_OPT_NONCM) {
if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_ALWAYS_ESCAPES) {
/* even if a continuation is captured, it won't get back */
return 1;
}
}
}
return 0;
}
#define IS_NAMED_PRIM(p, nm) (!strcmp(((Scheme_Primitive_Proc *)p)->name, nm)) #define IS_NAMED_PRIM(p, nm) (!strcmp(((Scheme_Primitive_Proc *)p)->name, nm))
static int wants_local_type_arguments(Scheme_Object *rator, int argpos) static int wants_local_type_arguments(Scheme_Object *rator, int argpos)
@ -2214,6 +2249,8 @@ static Scheme_Object *finish_optimize_application(Scheme_App_Rec *app, Optimize_
info->size += 1; info->size += 1;
if (!is_nonmutating_primitive(app->args[0], app->num_args)) if (!is_nonmutating_primitive(app->args[0], app->num_args))
info->vclock += 1; info->vclock += 1;
if (!is_noncapturing_primitive(app->args[0], app->num_args))
info->kclock += 1;
if (all_vals) { if (all_vals) {
le = try_optimize_fold(app->args[0], (Scheme_Object *)app, info); le = try_optimize_fold(app->args[0], (Scheme_Object *)app, info);
@ -2396,6 +2433,8 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz
if (!is_nonmutating_primitive(app->rator, 1)) if (!is_nonmutating_primitive(app->rator, 1))
info->vclock += 1; info->vclock += 1;
if (!is_noncapturing_primitive(app->rator, 1))
info->kclock += 1;
info->preserves_marks = !!(rator_flags & CLOS_PRESERVES_MARKS); info->preserves_marks = !!(rator_flags & CLOS_PRESERVES_MARKS);
info->single_result = !!(rator_flags & CLOS_SINGLE_RESULT); info->single_result = !!(rator_flags & CLOS_SINGLE_RESULT);
@ -2606,6 +2645,8 @@ static Scheme_Object *finish_optimize_application3(Scheme_App3_Rec *app, Optimiz
if (!is_nonmutating_primitive(app->rator, 2)) if (!is_nonmutating_primitive(app->rator, 2))
info->vclock += 1; info->vclock += 1;
if (!is_noncapturing_primitive(app->rator, 2))
info->kclock += 1;
/* Check for (call-with-values (lambda () M) N): */ /* Check for (call-with-values (lambda () M) N): */
if (SAME_OBJ(app->rator, scheme_call_with_values_proc)) { if (SAME_OBJ(app->rator, scheme_call_with_values_proc)) {
@ -3018,7 +3059,7 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int
Scheme_Branch_Rec *b; Scheme_Branch_Rec *b;
Scheme_Object *t, *tb, *fb; Scheme_Object *t, *tb, *fb;
Scheme_Hash_Tree *old_types; Scheme_Hash_Tree *old_types;
int preserves_marks = 1, single_result = 1; int preserves_marks = 1, single_result = 1, init_kclock, then_kclock;
b = (Scheme_Branch_Rec *)o; b = (Scheme_Branch_Rec *)o;
@ -3059,6 +3100,7 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int
} }
info->vclock += 1; /* model branch as clock increment */ info->vclock += 1; /* model branch as clock increment */
init_kclock = info->kclock;
if (SCHEME_TYPE(t) > _scheme_compiled_values_types_) { if (SCHEME_TYPE(t) > _scheme_compiled_values_types_) {
info->size -= 1; info->size -= 1;
@ -3087,6 +3129,8 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int
single_result = -1; single_result = -1;
info->types = old_types; info->types = old_types;
then_kclock = info->kclock;
info->kclock = init_kclock;
fb = scheme_optimize_expr(fb, info, scheme_optimize_tail_context(context)); fb = scheme_optimize_expr(fb, info, scheme_optimize_tail_context(context));
@ -3099,6 +3143,9 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int
else if (single_result && (info->single_result < 0)) else if (single_result && (info->single_result < 0))
single_result = -1; single_result = -1;
if (then_kclock > info->kclock)
info->kclock = then_kclock;
info->vclock += 1; /* model join as clock increment */ info->vclock += 1; /* model join as clock increment */
info->preserves_marks = preserves_marks; info->preserves_marks = preserves_marks;
info->single_result = single_result; info->single_result = single_result;
@ -3352,6 +3399,7 @@ apply_values_optimize(Scheme_Object *data, Optimize_Info *info, int context)
info->size += 1; info->size += 1;
info->vclock += 1; info->vclock += 1;
info->kclock += 1;
return scheme_optimize_apply_values(f, e, info, info->single_result, context); return scheme_optimize_apply_values(f, e, info, info->single_result, context);
} }
@ -3599,21 +3647,27 @@ static Scheme_Object *begin_for_syntax_optimize(Scheme_Object *data, Optimize_In
/* let, let-values, letrec, etc. */ /* let, let-values, letrec, etc. */
/*========================================================================*/ /*========================================================================*/
static int is_liftable_prim(Scheme_Object *v) static int is_liftable_prim(Scheme_Object *v, int or_escape)
{ {
if (SCHEME_PRIMP(v)) { if (SCHEME_PRIMP(v)) {
if ((((Scheme_Primitive_Proc *)v)->pp.flags & SCHEME_PRIM_OPT_MASK) int opt = (((Scheme_Primitive_Proc *)v)->pp.flags & SCHEME_PRIM_OPT_MASK);
>= SCHEME_PRIM_OPT_IMMEDIATE) if (opt >= SCHEME_PRIM_OPT_IMMEDIATE)
return 1; return 1;
if (or_escape && (opt >= SCHEME_PRIM_OPT_NONCM)) {
if (SCHEME_PRIM_PROC_OPT_FLAGS(v) & SCHEME_PRIM_ALWAYS_ESCAPES)
return 1;
}
} }
return 0; return 0;
} }
int scheme_is_liftable(Scheme_Object *o, int bind_count, int fuel, int as_rator) int scheme_is_liftable(Scheme_Object *o, int bind_count, int fuel, int as_rator, int or_escape)
{ {
Scheme_Type t = SCHEME_TYPE(o); Scheme_Type t = SCHEME_TYPE(o);
if (!fuel) return 0;
switch (t) { switch (t) {
case scheme_compiled_unclosed_procedure_type: case scheme_compiled_unclosed_procedure_type:
return !as_rator; return !as_rator;
@ -3626,11 +3680,11 @@ int scheme_is_liftable(Scheme_Object *o, int bind_count, int fuel, int as_rator)
return 1; return 1;
break; break;
case scheme_branch_type: case scheme_branch_type:
if (fuel) { {
Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)o; Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)o;
if (scheme_is_liftable(b->test, bind_count, fuel - 1, 0) if (scheme_is_liftable(b->test, bind_count, fuel - 1, 0, or_escape)
&& scheme_is_liftable(b->tbranch, bind_count, fuel - 1, as_rator) && scheme_is_liftable(b->tbranch, bind_count, fuel - 1, as_rator, or_escape)
&& scheme_is_liftable(b->fbranch, bind_count, fuel - 1, as_rator)) && scheme_is_liftable(b->fbranch, bind_count, fuel - 1, as_rator, or_escape))
return 1; return 1;
} }
break; break;
@ -3638,13 +3692,13 @@ int scheme_is_liftable(Scheme_Object *o, int bind_count, int fuel, int as_rator)
{ {
Scheme_App_Rec *app = (Scheme_App_Rec *)o; Scheme_App_Rec *app = (Scheme_App_Rec *)o;
int i; int i;
if (!is_liftable_prim(app->args[0])) if (!is_liftable_prim(app->args[0], or_escape))
return 0; return 0;
if (0) /* not resolved, yet */ if (0) /* not resolved, yet */
if (bind_count >= 0) if (bind_count >= 0)
bind_count += app->num_args; bind_count += app->num_args;
for (i = app->num_args + 1; i--; ) { for (i = app->num_args + 1; i--; ) {
if (!scheme_is_liftable(app->args[i], bind_count, fuel - 1, 1)) if (!scheme_is_liftable(app->args[i], bind_count, fuel - 1, 1, or_escape))
return 0; return 0;
} }
return 1; return 1;
@ -3653,27 +3707,27 @@ int scheme_is_liftable(Scheme_Object *o, int bind_count, int fuel, int as_rator)
case scheme_application2_type: case scheme_application2_type:
{ {
Scheme_App2_Rec *app = (Scheme_App2_Rec *)o; Scheme_App2_Rec *app = (Scheme_App2_Rec *)o;
if (!is_liftable_prim(app->rator)) if (!is_liftable_prim(app->rator, or_escape))
return 0; return 0;
if (0) /* not resolved, yet */ if (0) /* not resolved, yet */
if (bind_count >= 0) if (bind_count >= 0)
bind_count += 1; bind_count += 1;
if (scheme_is_liftable(app->rator, bind_count, fuel - 1, 1) if (scheme_is_liftable(app->rator, bind_count, fuel - 1, 1, or_escape)
&& scheme_is_liftable(app->rand, bind_count, fuel - 1, 1)) && scheme_is_liftable(app->rand, bind_count, fuel - 1, 1, or_escape))
return 1; return 1;
} }
break; break;
case scheme_application3_type: case scheme_application3_type:
{ {
Scheme_App3_Rec *app = (Scheme_App3_Rec *)o; Scheme_App3_Rec *app = (Scheme_App3_Rec *)o;
if (!is_liftable_prim(app->rator)) if (!is_liftable_prim(app->rator, or_escape))
return 0; return 0;
if (0) /* not resolved, yet */ if (0) /* not resolved, yet */
if (bind_count >= 0) if (bind_count >= 0)
bind_count += 2; bind_count += 2;
if (scheme_is_liftable(app->rator, bind_count, fuel - 1, 1) if (scheme_is_liftable(app->rator, bind_count, fuel - 1, 1, or_escape)
&& scheme_is_liftable(app->rand1, bind_count, fuel - 1, 1) && scheme_is_liftable(app->rand1, bind_count, fuel - 1, 1, or_escape)
&& scheme_is_liftable(app->rand2, bind_count, fuel - 1, 1)) && scheme_is_liftable(app->rand2, bind_count, fuel - 1, 1, or_escape))
return 1; return 1;
} }
break; break;
@ -3686,11 +3740,11 @@ int scheme_is_liftable(Scheme_Object *o, int bind_count, int fuel, int as_rator)
if (post_bind) { if (post_bind) {
o = lh->body; o = lh->body;
for (i = lh->num_clauses; i--; ) { for (i = lh->num_clauses; i--; ) {
if (!scheme_is_liftable(((Scheme_Compiled_Let_Value *)o)->value, bind_count, fuel - 1, as_rator)) if (!scheme_is_liftable(((Scheme_Compiled_Let_Value *)o)->value, bind_count, fuel - 1, as_rator, or_escape))
return 0; return 0;
o = ((Scheme_Compiled_Let_Value *)o)->body; o = ((Scheme_Compiled_Let_Value *)o)->body;
} }
if (scheme_is_liftable(o, bind_count + lh->count, fuel - 1, as_rator)) if (scheme_is_liftable(o, bind_count + lh->count, fuel - 1, as_rator, or_escape))
return 1; return 1;
} }
break; break;
@ -4007,7 +4061,7 @@ static int expr_size(Scheme_Object *o, Optimize_Info *info)
int scheme_might_invoke_call_cc(Scheme_Object *value) int scheme_might_invoke_call_cc(Scheme_Object *value)
{ {
return !scheme_is_liftable(value, -1, 10, 0); return !scheme_is_liftable(value, -1, 10, 0, 1);
} }
static int worth_lifting(Scheme_Object *v) static int worth_lifting(Scheme_Object *v)
@ -4498,7 +4552,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
if (cnt == 1) { if (cnt == 1) {
/* used only once; we may be able to shift the expression to the use /* used only once; we may be able to shift the expression to the use
site, instead of binding to a temporary */ site, instead of binding to a temporary */
once_used = make_once_used(value, pos, rhs_info->vclock, NULL); once_used = make_once_used(value, pos, rhs_info->vclock, rhs_info->kclock, NULL);
if (!last_once_used) if (!last_once_used)
first_once_used = once_used; first_once_used = once_used;
else else
@ -4518,7 +4572,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
cnt = ((pre_body->flags[i] & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT); cnt = ((pre_body->flags[i] & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT);
if (cnt == 1) { if (cnt == 1) {
/* Need to register as once-used, in case of copy propagation */ /* Need to register as once-used, in case of copy propagation */
once_used = make_once_used(NULL, pos+i, rhs_info->vclock, NULL); once_used = make_once_used(NULL, pos+i, rhs_info->vclock, rhs_info->kclock, NULL);
if (!last_once_used) if (!last_once_used)
first_once_used = once_used; first_once_used = once_used;
else else
@ -4540,7 +4594,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
&& !body_info->letrec_not_twice && !body_info->letrec_not_twice
&& ((i < 1) && ((i < 1)
|| (!scheme_is_compiled_procedure(((Scheme_Compiled_Let_Value *)pre_body->body)->value, 1, 1) || (!scheme_is_compiled_procedure(((Scheme_Compiled_Let_Value *)pre_body->body)->value, 1, 1)
&& !scheme_is_liftable(((Scheme_Compiled_Let_Value *)pre_body->body)->value, head->count, 5, 1)))) { && !scheme_is_liftable(((Scheme_Compiled_Let_Value *)pre_body->body)->value, head->count, 5, 1, 0)))) {
Scheme_Object *prop_later = NULL; Scheme_Object *prop_later = NULL;
if (did_set_value) { if (did_set_value) {
@ -4711,6 +4765,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
info->single_result = body_info->single_result; info->single_result = body_info->single_result;
info->preserves_marks = body_info->preserves_marks; info->preserves_marks = body_info->preserves_marks;
info->vclock = body_info->vclock; info->vclock = body_info->vclock;
info->kclock = body_info->kclock;
/* Clear used flags where possible */ /* Clear used flags where possible */
body = head->body; body = head->body;
@ -4754,8 +4809,12 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
pre_body->flags[j] |= SCHEME_WAS_USED; pre_body->flags[j] |= SCHEME_WAS_USED;
ct = optimize_is_local_type_arg(body_info, pos+j, 0); ct = optimize_is_local_type_arg(body_info, pos+j, 0);
if (ct) if (ct) {
if (ALWAYS_PREFER_UNBOX_TYPE(ct)
|| !optimize_escapes_after_k_tick(body_info, pos+j))
pre_body->flags[j] |= (ct << SCHEME_WAS_TYPED_ARGUMENT_SHIFT); pre_body->flags[j] |= (ct << SCHEME_WAS_TYPED_ARGUMENT_SHIFT);
}
if (first_once_used && (first_once_used->pos == (pos+j))) { if (first_once_used && (first_once_used->pos == (pos+j))) {
if (first_once_used->vclock < 0) { if (first_once_used->vclock < 0) {
@ -4865,6 +4924,7 @@ optimize_closure_compilation(Scheme_Object *_data, Optimize_Info *info, int cont
SCHEME_LAMBDA_FRAME); SCHEME_LAMBDA_FRAME);
info->vclock += 1; /* model delayed evaluation as vclock increment */ info->vclock += 1; /* model delayed evaluation as vclock increment */
info->kclock += 1;
/* For reporting warnings: */ /* For reporting warnings: */
if (info->context && SCHEME_PAIRP(info->context)) if (info->context && SCHEME_PAIRP(info->context))
@ -4883,7 +4943,7 @@ optimize_closure_compilation(Scheme_Object *_data, Optimize_Info *info, int cont
cnt = ((cl->local_flags[i] & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT); cnt = ((cl->local_flags[i] & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT);
if (cnt == 1) { if (cnt == 1) {
last_once_used = make_once_used(NULL, i, info->vclock, last_once_used); last_once_used = make_once_used(NULL, i, info->vclock, info->kclock, last_once_used);
if (!first_once_used) first_once_used = last_once_used; if (!first_once_used) first_once_used = last_once_used;
optimize_propagate(info, i, (Scheme_Object *)last_once_used, 1); optimize_propagate(info, i, (Scheme_Object *)last_once_used, 1);
} }
@ -5856,7 +5916,9 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info, in
if (((o->vclock == info->vclock) if (((o->vclock == info->vclock)
&& single_valued_noncm_expression(o->expr, 5)) && single_valued_noncm_expression(o->expr, 5))
|| ((o->vclock != info->vclock) || ((o->vclock != info->vclock)
&& movable_expression(o->expr, info, o->delta, o->cross_lambda, 0, 5))) { && movable_expression(o->expr, info, o->delta, o->cross_lambda,
o->kclock != info->kclock,
0, 5))) {
val = optimize_clone(1, o->expr, info, o->delta, 0); val = optimize_clone(1, o->expr, info, o->delta, 0);
if (val) { if (val) {
info->size -= 1; info->size -= 1;
@ -6621,7 +6683,7 @@ static void optimize_propagate(Optimize_Info *info, int pos, Scheme_Object *valu
info->consts = p; info->consts = p;
} }
static Scheme_Once_Used *make_once_used(Scheme_Object *val, int pos, int vclock, Scheme_Once_Used *prev) static Scheme_Once_Used *make_once_used(Scheme_Object *val, int pos, int vclock, int kclock, Scheme_Once_Used *prev)
{ {
Scheme_Once_Used *o; Scheme_Once_Used *o;
@ -6631,6 +6693,7 @@ static Scheme_Once_Used *make_once_used(Scheme_Object *val, int pos, int vclock,
o->expr = val; o->expr = val;
o->pos = pos; o->pos = pos;
o->vclock = vclock; o->vclock = vclock;
o->kclock = kclock;
if (prev) if (prev)
prev->next = o; prev->next = o;
@ -6740,6 +6803,12 @@ static int optimize_is_mutated(Optimize_Info *info, int pos)
return check_use(info, pos, OPT_IS_MUTATED, 0); return check_use(info, pos, OPT_IS_MUTATED, 0);
} }
static int optimize_escapes_after_k_tick(Optimize_Info *info, int pos)
/* pos is in new-frame counts */
{
return check_use(info, pos, OPT_ESCAPES_AFTER_K_TICK, 0);
}
static int optimize_is_local_type_arg(Optimize_Info *info, int pos, int depth) static int optimize_is_local_type_arg(Optimize_Info *info, int pos, int depth)
/* pos is in new-frame counts */ /* pos is in new-frame counts */
{ {
@ -6785,7 +6854,7 @@ static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int
int disrupt_single_use, int *is_mutated, int just_test) int disrupt_single_use, int *is_mutated, int just_test)
{ {
Scheme_Object *p, *n; Scheme_Object *p, *n;
int delta = 0, orig_j = j; int delta = 0, orig_j = j, kclock = info->kclock;
while (info) { while (info) {
if (info->flags & SCHEME_LAMBDA_FRAME) if (info->flags & SCHEME_LAMBDA_FRAME)
@ -6799,6 +6868,8 @@ static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int
if (OPT_CONTEXT_TYPE(context)) if (OPT_CONTEXT_TYPE(context))
register_use(info, pos, OPT_CONTEXT_TYPE(context) << OPT_LOCAL_TYPE_ARG_SHIFT); register_use(info, pos, OPT_CONTEXT_TYPE(context) << OPT_LOCAL_TYPE_ARG_SHIFT);
else if (!just_test && (kclock > info->init_kclock))
register_use(info, pos, OPT_ESCAPES_AFTER_K_TICK);
if (is_mutated) if (is_mutated)
if (info->use && (info->use[pos] & OPT_IS_MUTATED)) if (info->use && (info->use[pos] & OPT_IS_MUTATED))
@ -6964,6 +7035,8 @@ static Optimize_Info *optimize_info_add_frame(Optimize_Info *info, int orig, int
naya->top_level_consts = info->top_level_consts; naya->top_level_consts = info->top_level_consts;
naya->context = info->context; naya->context = info->context;
naya->vclock = info->vclock; naya->vclock = info->vclock;
naya->kclock = info->kclock;
naya->init_kclock = info->kclock;
naya->use_psize = info->use_psize; naya->use_psize = info->use_psize;
naya->logger = info->logger; naya->logger = info->logger;
@ -6994,6 +7067,7 @@ static void optimize_info_done(Optimize_Info *info, Optimize_Info *parent)
parent->size += info->size; parent->size += info->size;
parent->vclock = info->vclock; parent->vclock = info->vclock;
parent->kclock = info->kclock;
parent->psize += info->psize; parent->psize += info->psize;
if (info->has_nonleaf) if (info->has_nonleaf)
parent->has_nonleaf = 1; parent->has_nonleaf = 1;

2
racket/src/racket/src/resolve.c
View File

@ -999,7 +999,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
else if (SCHEME_CLV_FLAGS(clv) & SCHEME_CLV_NO_GROUP_USES) else if (SCHEME_CLV_FLAGS(clv) & SCHEME_CLV_NO_GROUP_USES)
is_lift = 1; is_lift = 1;
else else
is_lift = scheme_is_liftable(clv->value, head->count, 5, 1); is_lift = scheme_is_liftable(clv->value, head->count, 5, 1, 0);
if (!is_proc && !is_lift) { if (!is_proc && !is_lift) {
recbox = 1; recbox = 1;

11
racket/src/racket/src/schpriv.h
View File

@ -49,7 +49,10 @@
/* Flonum unboxing is only useful if a value is going to flow to a /* Flonum unboxing is only useful if a value is going to flow to a
function that wants it, otherwise we'll have to box the flonum anyway. function that wants it, otherwise we'll have to box the flonum anyway.
Fixnum unboxing is always fine, since it's easy to box. */ Also, we can only leave flonums unboxed if they don't escape
before a potential continuation capture.
Fixnum unboxing is always fine, since it's easy to box and doesn't
involve allocation. */
#define ALWAYS_PREFER_UNBOX_TYPE(ty) ((ty) == SCHEME_LOCAL_TYPE_FIXNUM) #define ALWAYS_PREFER_UNBOX_TYPE(ty) ((ty) == SCHEME_LOCAL_TYPE_FIXNUM)
#define IN_FIXNUM_RANGE_ON_ALL_PLATFORMS(v) (((v) >= -1073741824) && ((v) <= 1073741823)) #define IN_FIXNUM_RANGE_ON_ALL_PLATFORMS(v) (((v) >= -1073741824) && ((v) <= 1073741823))
@ -68,8 +71,10 @@
#define SCHEME_PRIM_WANTS_EXTFLONUM_FIRST 512 #define SCHEME_PRIM_WANTS_EXTFLONUM_FIRST 512
#define SCHEME_PRIM_WANTS_EXTFLONUM_SECOND 1024 #define SCHEME_PRIM_WANTS_EXTFLONUM_SECOND 1024
#define SCHEME_PRIM_WANTS_EXTFLONUM_THIRD 2048 #define SCHEME_PRIM_WANTS_EXTFLONUM_THIRD 2048
#define SCHEME_PRIM_IS_UNSAFE_NONALLOCATE 4096
#define SCHEME_PRIM_ALWAYS_ESCAPES 8192
#define SCHEME_PRIM_OPT_TYPE_SHIFT 12 #define SCHEME_PRIM_OPT_TYPE_SHIFT 13
#define SCHEME_PRIM_OPT_TYPE_MASK (SCHEME_MAX_LOCAL_TYPE_MASK << SCHEME_PRIM_OPT_TYPE_SHIFT) #define SCHEME_PRIM_OPT_TYPE_MASK (SCHEME_MAX_LOCAL_TYPE_MASK << SCHEME_PRIM_OPT_TYPE_SHIFT)
#define SCHEME_PRIM_OPT_TYPE(x) ((x & SCHEME_PRIM_OPT_TYPE_MASK) >> SCHEME_PRIM_OPT_TYPE_SHIFT) #define SCHEME_PRIM_OPT_TYPE(x) ((x & SCHEME_PRIM_OPT_TYPE_MASK) >> SCHEME_PRIM_OPT_TYPE_SHIFT)
@ -3068,7 +3073,7 @@ int scheme_used_ever(Scheme_Comp_Env *env, int which);
int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
Optimize_Info *opt_info, Optimize_Info *warn_info, int deeper_than, int no_id); Optimize_Info *opt_info, Optimize_Info *warn_info, int deeper_than, int no_id);
int scheme_might_invoke_call_cc(Scheme_Object *value); int scheme_might_invoke_call_cc(Scheme_Object *value);
int scheme_is_liftable(Scheme_Object *o, int bind_count, int fuel, int as_rator); int scheme_is_liftable(Scheme_Object *o, int bind_count, int fuel, int as_rator, int or_escape);
int scheme_is_functional_primitive(Scheme_Object *rator, int num_args, int expected_vals); int scheme_is_functional_primitive(Scheme_Object *rator, int num_args, int expected_vals);
typedef struct { typedef struct {

4
racket/src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.) consistently.)
*/ */
#define MZSCHEME_VERSION "6.0.0.3" #define MZSCHEME_VERSION "6.0.0.4"
#define MZSCHEME_VERSION_X 6 #define MZSCHEME_VERSION_X 6
#define MZSCHEME_VERSION_Y 0 #define MZSCHEME_VERSION_Y 0
#define MZSCHEME_VERSION_Z 0 #define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 3 #define MZSCHEME_VERSION_W 4
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)