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

370.3

Browse Source 
svn: r6545
This commit is contained in:
Matthew Flatt 2007-06-08 08:03:06 +00:00
parent a6c36a3739
commit 63ce7b93fb
14 changed files with 3872 additions and 3472 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/mzlib/for.ss
View File

@ -27,7 +27,7 @@
stop-after
(rename *in-indexed in-indexed)
sequence-generator
sequence-generate
define-sequence-syntax
make-do-sequence
@ -520,9 +520,9 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; runnign sequences outside of a loop:
(define (sequence-generator g)
(define (sequence-generate g)
(unless (sequence? g)
(raise-type-error 'sequence-generator "sequence" g))
(raise-type-error 'sequence-generate "sequence" g))
(let-values ([(pos->val pos-next init pos-cont? pre-cont? post-cont?)
(make-sequence #f g)])
(let ([pos init])

34
collects/tests/mzscheme/basic.ss
View File

@ -2015,9 +2015,18 @@
h1))])
(let ([check-tables-equal
(lambda (mode t1 t2)
(lambda (mode t1 t2 flag)
(test #t equal? t1 t2)
(test (equal-hash-code t1) equal-hash-code t2)
(test (equal-hash-code t1) equal-hash-code t2)
(test #t equal? t1 (hash-table-copy t1))
(let ([again (apply make-hash-table 'equal flag)])
(let loop ([i (hash-table-iterate-first t1)])
(when i
(hash-table-put! again
(hash-table-iterate-key t1 i)
(hash-table-iterate-value t1 i))
(loop (hash-table-iterate-next t1 i))))
(test #t equal? t1 again))
(let ([meta-ht (make-hash-table 'equal)])
(hash-table-put! meta-ht t1 mode)
(test mode hash-table-get meta-ht t2 (lambda () #f)))
@ -2025,10 +2034,12 @@
(check-tables-equal 'the-norm-table
(check-hash-tables null #f)
(check-hash-tables null #t))
(check-hash-tables null #t)
null)
(check-tables-equal 'the-weak-table
(check-hash-tables (list 'weak) #f)
(check-hash-tables (list 'weak) #t)))
(check-hash-tables (list 'weak) #t)
(list 'weak)))
(save))) ; prevents gcing of the ht-registered values
@ -2104,6 +2115,21 @@
(test 2 hash-table-get (hash-table-copy #hasheq((1 . 2))) 1)
(test (void) hash-table-put! (hash-table-copy #hasheq((1 . 2))) 3 4)
(test #f hash-table-iterate-first (make-hash-table))
(test #f hash-table-iterate-first (make-hash-table 'weak))
(err/rt-test (hash-table-iterate-next (make-hash-table) 0))
(err/rt-test (hash-table-iterate-next (make-hash-table 'weak) 0))
(let ([check-all-bad
(lambda (op)
(err/rt-test (op #f 0))
(err/rt-test (op (make-hash-table) -1))
(err/rt-test (op (make-hash-table) (- (expt 2 100))))
(err/rt-test (op (make-hash-table) 1.0)))])
(check-all-bad hash-table-iterate-next)
(check-all-bad hash-table-iterate-key)
(check-all-bad hash-table-iterate-value))
(arity-test make-hash-table 0 2)
(arity-test make-immutable-hash-table 1 2)
(arity-test hash-table-count 1 1)

53
collects/tests/mzscheme/optimize.ss
View File

@ -434,6 +434,59 @@
'(let ([x (random)])
x))
(test-comp '(let-values ([(x y) (values 1 2)])
(+ x y))
3)
(test-comp '(letrec ([x 3]
[f (lambda (y) x)])
f)
'(letrec ([f (lambda (y) 3)])
f))
(test-comp '(letrec ([x 3]
[f (lambda (y) x)])
(f 10))
3)
(test-comp '(letrec ([f (lambda (y) (f y))])
3)
3)
(test-comp '(letrec ([len (lambda (l)
(if (null? l)
0
(len (cdr l))))])
(len null))
0)
(test-comp '(letrec ([foo (lambda ()
(set! foo 10))])
0)
0)
(test-comp '(letrec ([foo (lambda () 12)]
[goo (lambda () foo)])
goo)
'(let* ([foo (lambda () 12)]
[goo (lambda () foo)])
goo))
(test-comp '(let* ([foo (lambda () 12)]
[goo (lambda () foo)])
11)
11)
(test-comp '(letrec ([foo (lambda () 12)]
[goo (lambda () foo)])
11)
11)
(test-comp '(letrec ([goo (lambda () foo)]
[foo (lambda () goo)])
15)
15)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check bytecode verification of lifted functions

8
collects/tests/mzscheme/sync.ss
View File

@ -872,17 +872,21 @@
(break-enabled #f))
(init ;; init function gets to decide whether to do the normal body:
(lambda ()
(printf "here ~s\n" (procedure? capture-pre))
(dynamic-wind
(lambda ()
(printf "here3 ~s\n" (procedure? capture-pre))
(capture-pre
reset
(lambda ()
(printf "here4\n")
(set! did-pre1 #t)
(semaphore-post p)
(pre-thunk)
(pre-semaphore-wait s)
(set! did-pre2 #t))))
(lambda ()
(printf "here2\n")
(capture-act
reset
(lambda ()
@ -930,6 +934,7 @@
;; create fresh semaphores
(set! s (make-semaphore))
(set! p (make-semaphore))
(printf "mk ~s\n" mk-t*)
;; create the thread
(let ([t (mk-t* break-off?
pre-thunk act-thunk post-thunk
@ -1016,6 +1021,9 @@
(body))])
;; Grab a continuation for the dyn-wind's pre/act/post
(go (lambda args
(printf "here???\n")
(printf "??? ~s\n" k+reset)
(printf "??? ~s\n" capture)
(apply mk-t
(lambda (f) (f))
(if (eq? which 'pre) capture no-capture)

3
doc/release-notes/mzscheme/HISTORY
View File

@ -1,3 +1,6 @@
Version 370.2
Added hash-table-iterate-{first,next,key,value}
Version 370.2
Added make-sibling-inspector
Added graph? argument to read[-syntax]/recursive

6429
src/mzscheme/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

108
src/mzscheme/src/env.c
View File

@ -29,6 +29,7 @@
#include "schpriv.h"
#include "schminc.h"
#include "schmach.h"
#include "schexpobs.h"
#if defined(UNIX_LIMIT_STACK) || defined(UNIX_LIMIT_FDSET_SIZE)
@ -2650,6 +2651,8 @@ Optimize_Info *scheme_optimize_info_create()
return info;
}
static void register_transitive_use(Optimize_Info *info, int pos, int j);
static void register_stat_dist(Optimize_Info *info, int i, int j)
{
if (!info->stat_dists) {
@ -2681,16 +2684,81 @@ static void register_stat_dist(Optimize_Info *info, int i, int j)
info->sd_depths[i] = j + 1;
}
if (info->transitive_use && info->transitive_use[i]) {
/* We're using a procedure that we weren't sure would be used.
Transitively mark everything that the procedure uses --- unless
a transitive accumulation is in effect, in which case we
don't for this one now, leaving it to be triggered when
the one we're accumulating is triggered. */
if (!info->transitive_use_pos) {
mzshort *map = info->transitive_use[i];
int len = info->transitive_use_len[i];
int k;
info->transitive_use[i] = NULL;
for (k = 0; k < len; k++) {
register_transitive_use(info, map[k], 0);
}
}
}
info->stat_dists[i][j] = 1;
}
static Scheme_Object *transitive_k(void)
{
Scheme_Thread *p = scheme_current_thread;
Optimize_Info *info = (Optimize_Info *)p->ku.k.p1;
p->ku.k.p1 = NULL;
register_transitive_use(info, p->ku.k.i1, p->ku.k.i2);
return scheme_false;
}
static void register_transitive_use(Optimize_Info *info, int pos, int j)
{
#ifdef DO_STACK_CHECK
# include "mzstkchk.h"
{
Scheme_Thread *p = scheme_current_thread;
p->ku.k.p1 = (void *)info;
p->ku.k.i1 = pos;
p->ku.k.i2 = j;
scheme_handle_stack_overflow(transitive_k);
return;
}
#endif
while (info) {
if (info->flags & SCHEME_LAMBDA_FRAME)
j++;
if (pos < info->new_frame)
break;
pos -= info->new_frame;
info = info->next;
}
if (info->sd_depths[pos] <= j) {
scheme_signal_error("bad transitive position depth: %d vs. %d",
info->sd_depths[pos], j);
}
register_stat_dist(info, pos, j);
}
void scheme_env_make_closure_map(Optimize_Info *info, mzshort *_size, mzshort **_map)
{
/* A closure map lists the captured variables for a closure; the
indices are resolved two new indicies in the second phase of
compilation. */
Optimize_Info *frame;
int i, j, pos = 0, lpos = 0;
int i, j, pos = 0, lpos = 0, tu;
mzshort *map, size;
/* Count vars used by this closure (skip args): */
@ -2715,6 +2783,13 @@ void scheme_env_make_closure_map(Optimize_Info *info, mzshort *_size, mzshort **
map = MALLOC_N_ATOMIC(mzshort, size);
*_map = map;
if (info->next && info->next->transitive_use_pos) {
info->next->transitive_use[info->next->transitive_use_pos - 1] = map;
info->next->transitive_use_len[info->next->transitive_use_pos - 1] = size;
tu = 1;
} else
tu = 0;
/* Build map, unmarking locals and marking deeper in parent frame */
j = 1; pos = 0;
for (frame = info->next; frame; frame = frame->next) {
@ -2727,7 +2802,8 @@ void scheme_env_make_closure_map(Optimize_Info *info, mzshort *_size, mzshort **
if (frame->stat_dists[i][j]) {
map[pos++] = lpos;
frame->stat_dists[i][j] = 0; /* This closure's done with these vars... */
frame->stat_dists[i][j - 1] = 1; /* ... but ensure previous keeps */
if (!tu)
frame->stat_dists[i][j - 1] = 1; /* ... but ensure previous keeps */
}
}
lpos++;
@ -2829,6 +2905,34 @@ int scheme_optimize_is_used(Optimize_Info *info, int pos)
return 0;
}
int scheme_optimize_any_uses(Optimize_Info *info, int start_pos, int end_pos)
{
int j, i;
if (info->stat_dists) {
for (i = start_pos; i < end_pos; i++) {
for (j = info->sd_depths[i]; j--; ) {
if (info->stat_dists[i][j])
return 1;
}
}
}
if (info->transitive_use) {
for (i = info->new_frame; i--; ) {
if (info->transitive_use[i]) {
for (j = info->transitive_use_len[i]; j--; ) {
if ((info->transitive_use[i][j] >= start_pos)
&& (info->transitive_use[i][j] < end_pos))
return 1;
}
}
}
}
return 0;
}
static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int j, int *closure_offset)
{
Scheme_Object *p, *n;

186
src/mzscheme/src/list.c
View File

@ -94,6 +94,10 @@ static Scheme_Object *hash_table_get(int argc, Scheme_Object *argv[]);
static Scheme_Object *hash_table_remove(int argc, Scheme_Object *argv[]);
static Scheme_Object *hash_table_map(int argc, Scheme_Object *argv[]);
static Scheme_Object *hash_table_for_each(int argc, Scheme_Object *argv[]);
static Scheme_Object *hash_table_iterate_start(int argc, Scheme_Object *argv[]);
static Scheme_Object *hash_table_iterate_next(int argc, Scheme_Object *argv[]);
static Scheme_Object *hash_table_iterate_value(int argc, Scheme_Object *argv[]);
static Scheme_Object *hash_table_iterate_key(int argc, Scheme_Object *argv[]);
static Scheme_Object *eq_hash_code(int argc, Scheme_Object *argv[]);
static Scheme_Object *equal_hash_code(int argc, Scheme_Object *argv[]);
@ -465,6 +469,27 @@ scheme_init_list (Scheme_Env *env)
2, 2),
env);
scheme_add_global_constant("hash-table-iterate-first",
scheme_make_noncm_prim(hash_table_iterate_start,
"hash-table-iterate-first",
1, 1),
env);
scheme_add_global_constant("hash-table-iterate-next",
scheme_make_noncm_prim(hash_table_iterate_next,
"hash-table-iterate-next",
2, 2),
env);
scheme_add_global_constant("hash-table-iterate-value",
scheme_make_noncm_prim(hash_table_iterate_value,
"hash-table-iterate-value",
2, 2),
env);
scheme_add_global_constant("hash-table-iterate-key",
scheme_make_noncm_prim(hash_table_iterate_key,
"hash-table-iterate-key",
2, 2),
env);
scheme_add_global_constant("eq-hash-code",
scheme_make_noncm_prim(eq_hash_code,
"eq-hash-code",
@ -1701,6 +1726,167 @@ static Scheme_Object *hash_table_for_each(int argc, Scheme_Object *argv[])
return do_map_hash_table(argc, argv, "hash-table-for-each", 0);
}
static Scheme_Object *hash_table_next(const char *name, int start, int argc, Scheme_Object *argv[])
{
if (SCHEME_HASHTP(argv[0])) {
Scheme_Hash_Table *hash;
int i, sz;
hash = (Scheme_Hash_Table *)argv[0];
sz = hash->size;
if (start >= 0) {
if ((start >= sz) || !hash->vals[start])
return NULL;
}
for (i = start + 1; i < sz; i++) {
if (hash->vals[i])
return scheme_make_integer(i);
}
return scheme_false;
} else if (SCHEME_BUCKTP(argv[0])) {
Scheme_Bucket_Table *hash;
Scheme_Bucket *bucket;
int i, sz;
hash = (Scheme_Bucket_Table *)argv[0];
sz = hash->size;
if (start >= 0) {
bucket = ((start < sz) ? hash->buckets[start] : NULL);
if (!bucket || !bucket->val || !bucket->key)
return NULL;
}
for (i = start + 1; i < sz; i++) {
bucket = hash->buckets[i];
if (bucket && bucket->val && bucket->key) {
return scheme_make_integer(i);
}
}
return scheme_false;
} else {
scheme_wrong_type(name, "hash table", 0, argc, argv);
return NULL;
}
}
static Scheme_Object *hash_table_iterate_start(int argc, Scheme_Object *argv[])
{
return hash_table_next("hash-table-iterate-first", -1, argc, argv);
}
static Scheme_Object *hash_table_iterate_next(int argc, Scheme_Object *argv[])
{
Scheme_Object *p = argv[1], *v;
int pos;
if (SCHEME_INTP(p)) {
pos = SCHEME_INT_VAL(p);
if (pos < 0)
pos = 0x7FFFFFFE;
} else {
pos = 0x7FFFFFFE;
}
v = hash_table_next("hash-table-iterate-next", pos, argc, argv);
if (v)
return v;
if (SCHEME_INTP(p)) {
if (SCHEME_INT_VAL(p) >= 0)
p = NULL;
} else if (SCHEME_BIGNUMP(p)) {
if (SCHEME_BIGPOS(p))
p = NULL;
}
if (p)
scheme_wrong_type("hash-table-iterate-next", "exact non-negative integer", 1, argc, argv);
scheme_arg_mismatch("hash-table-iterate-next", "no element at index: ", argv[1]);
return NULL;
}
static Scheme_Object *hash_table_index(const char *name, int argc, Scheme_Object *argv[], int get_val)
{
Scheme_Object *p = argv[1];
int pos, sz;
if (SCHEME_INTP(p)) {
pos = SCHEME_INT_VAL(p);
if (pos < 0)
pos = 0x7FFFFFFF;
} else {
pos = 0x7FFFFFFF;
}
if (SCHEME_HASHTP(argv[0])) {
Scheme_Hash_Table *hash;
hash = (Scheme_Hash_Table *)argv[0];
sz = hash->size;
if (pos < sz) {
if (hash->vals[pos]) {
if (get_val)
return hash->vals[pos];
else
return hash->keys[pos];
}
}
} else if (SCHEME_BUCKTP(argv[0])) {
Scheme_Bucket_Table *hash;
int sz;
Scheme_Bucket *bucket;
hash = (Scheme_Bucket_Table *)argv[0];
sz = hash->size;
if (pos < sz) {
bucket = hash->buckets[pos];
if (bucket && bucket->val && bucket->key) {
if (get_val)
return (Scheme_Object *)bucket->val;
else {
if (hash->weak)
return (Scheme_Object *)HT_EXTRACT_WEAK(bucket->key);
else
return (Scheme_Object *)bucket->key;
}
}
}
} else {
scheme_wrong_type(name, "hash table", 0, argc, argv);
return NULL;
}
if ((SCHEME_INTP(p)
&& (SCHEME_INT_VAL(p) >= 0))
|| (SCHEME_BIGNUMP(p)
&& SCHEME_BIGPOS(p))) {
scheme_arg_mismatch(name, "no element at index: ", p);
return NULL;
}
scheme_wrong_type(name, "exact non-negative integer", 1, argc, argv);
return NULL;
}
static Scheme_Object *hash_table_iterate_value(int argc, Scheme_Object *argv[])
{
return hash_table_index("hash-table-iterate-value", argc, argv, 1);
}
static Scheme_Object *hash_table_iterate_key(int argc, Scheme_Object *argv[])
{
return hash_table_index("hash-table-iterate-key", argc, argv, 0);
}
static Scheme_Object *eq_hash_code(int argc, Scheme_Object *argv[])
{
long v;

4
src/mzscheme/src/mzmark.c
View File

@ -2688,6 +2688,8 @@ static int mark_optimize_info_MARK(void *p) {
gcMARK(i->use);
gcMARK(i->consts);
gcMARK(i->top_level_consts);
gcMARK(i->transitive_use);
gcMARK(i->transitive_use_len);
return
gcBYTES_TO_WORDS(sizeof(Optimize_Info));
@ -2702,6 +2704,8 @@ static int mark_optimize_info_FIXUP(void *p) {
gcFIXUP(i->use);
gcFIXUP(i->consts);
gcFIXUP(i->top_level_consts);
gcFIXUP(i->transitive_use);
gcFIXUP(i->transitive_use_len);
return
gcBYTES_TO_WORDS(sizeof(Optimize_Info));

2
src/mzscheme/src/mzmarksrc.c
View File

@ -1075,6 +1075,8 @@ mark_optimize_info {
gcMARK(i->use);
gcMARK(i->consts);
gcMARK(i->top_level_consts);
gcMARK(i->transitive_use);
gcMARK(i->transitive_use_len);
size:
gcBYTES_TO_WORDS(sizeof(Optimize_Info));

2
src/mzscheme/src/schminc.h
View File

@ -13,7 +13,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 898
#define EXPECTED_PRIM_COUNT 902
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

5
src/mzscheme/src/schpriv.h
View File

@ -1744,6 +1744,10 @@ typedef struct Optimize_Info
int *sd_depths;
int used_toplevel;
char *use;
int transitive_use_pos; /* set to pos + 1 when optimizing a letrec-bound procedure */
mzshort **transitive_use;
int *transitive_use_len;
} Optimize_Info;
typedef struct Scheme_Object *(*Scheme_Syntax_Optimizer)(Scheme_Object *data, Optimize_Info *info);
@ -1991,6 +1995,7 @@ void scheme_optimize_info_used_top(Optimize_Info *info);
void scheme_optimize_mutated(Optimize_Info *info, int pos);
Scheme_Object *scheme_optimize_reverse(Optimize_Info *info, int pos, int unless_mutated);
int scheme_optimize_is_used(Optimize_Info *info, int pos);
int scheme_optimize_any_uses(Optimize_Info *info, int start_pos, int end_pos);
Scheme_Object *scheme_optimize_clone(int dup_ok, Scheme_Object *obj, Optimize_Info *info, int delta, int closure_depth);
Scheme_Object *scheme_optimize_shift(Scheme_Object *obj, int delta, int after_depth);

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

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 370
#define MZSCHEME_VERSION_MINOR 2
#define MZSCHEME_VERSION_MINOR 3
#define MZSCHEME_VERSION "370.2" _MZ_SPECIAL_TAG
#define MZSCHEME_VERSION "370.3" _MZ_SPECIAL_TAG

500
src/mzscheme/src/syntax.c
View File

@ -2559,6 +2559,42 @@ int scheme_compiled_propagate_ok(Scheme_Object *value, Optimize_Info *info)
return 0;
}
static int is_values_apply(Scheme_Object *e)
{
if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) {
Scheme_App_Rec *app = (Scheme_App_Rec *)e;
return SAME_OBJ(scheme_values_func, app->args[0]);
} else if (SAME_TYPE(SCHEME_TYPE(e), scheme_application2_type)) {
Scheme_App2_Rec *app = (Scheme_App2_Rec *)e;
return SAME_OBJ(scheme_values_func, app->rator);
} else if (SAME_TYPE(SCHEME_TYPE(e), scheme_application3_type)) {
Scheme_App3_Rec *app = (Scheme_App3_Rec *)e;
return SAME_OBJ(scheme_values_func, app->rator);
}
return 0;
}
static void unpack_values_application(Scheme_Object *e, Scheme_Compiled_Let_Value *naya)
{
if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) {
Scheme_App_Rec *app = (Scheme_App_Rec *)e;
int i;
for (i = 0; i < app->num_args; i++) {
naya->value = app->args[i + 1];
naya = (Scheme_Compiled_Let_Value *)naya->body;
}
} else if (SAME_TYPE(SCHEME_TYPE(e), scheme_application2_type)) {
Scheme_App2_Rec *app = (Scheme_App2_Rec *)e;
naya->value = app->rand;
} else if (SAME_TYPE(SCHEME_TYPE(e), scheme_application3_type)) {
Scheme_App3_Rec *app = (Scheme_App3_Rec *)e;
naya->value = app->rand1;
naya = (Scheme_Compiled_Let_Value *)naya->body;
naya->value = app->rand2;
}
}
static Scheme_Object *make_clones(Scheme_Compiled_Let_Value *retry_start,
Scheme_Compiled_Let_Value *pre_body,
Optimize_Info *body_info)
@ -2597,6 +2633,7 @@ static int set_code_flags(Scheme_Compiled_Let_Value *retry_start,
Scheme_Compiled_Let_Value *clv;
Scheme_Object *value, *first;
int flags = CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS;
Scheme_Closure_Data *data;
/* The first in a clone pair is the one that is consulted for
references. The second one is the clone, and its the one whose
@ -2606,16 +2643,21 @@ static int set_code_flags(Scheme_Compiled_Let_Value *retry_start,
clv = retry_start;
while (clones) {
value = retry_start->value;
first = SCHEME_CAR(clones);
if (SAME_OBJ(value, SCHEME_CAR(first))) {
Scheme_Closure_Data *data;
data = (Scheme_Closure_Data *)SCHEME_CDR(first);
if (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(value))) {
data = (Scheme_Closure_Data *)value;
flags = (flags & SCHEME_CLOSURE_DATA_FLAGS(data));
first = SCHEME_CAR(clones);
data = (Scheme_Closure_Data *)SCHEME_CDR(first);
SCHEME_CLOSURE_DATA_FLAGS(data) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data) & mask_flags);
data = (Scheme_Closure_Data *)SCHEME_CAR(first);
SCHEME_CLOSURE_DATA_FLAGS(data) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data) & mask_flags);
clones = SCHEME_CDR(clones);
}
if (clv == pre_body)
break;
clv = (Scheme_Compiled_Let_Value *)clv->body;
@ -2629,9 +2671,9 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
{
Optimize_Info *body_info, *rhs_info;
Scheme_Let_Header *head = (Scheme_Let_Header *)form;
Scheme_Compiled_Let_Value *clv, *pre_body, *retry_start;
Scheme_Compiled_Let_Value *clv, *pre_body, *retry_start, *prev_body;
Scheme_Object *body, *value;
int i, j, pos, is_rec, all_simple = 1;
int i, j, pos, is_rec, not_simply_let_star = 0;
int size_before_opt, did_set_value;
/* Special case: (let ([x E]) x) where E is lambda, case-lambda, or
@ -2671,8 +2713,6 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
rhs_info = body_info;
is_rec = (SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE);
if (is_rec)
all_simple = 0;
body = head->body;
pos = 0;
@ -2681,13 +2721,13 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
for (j = pre_body->count; j--; ) {
if (pre_body->flags[j] & SCHEME_WAS_SET_BANGED) {
scheme_optimize_mutated(body_info, pos + j);
all_simple = 0;
}
}
pos += pre_body->count;
body = pre_body->body;
}
prev_body = NULL;
body = head->body;
pre_body = NULL;
retry_start = NULL;
@ -2696,21 +2736,75 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
for (i = head->num_clauses; i--; ) {
pre_body = (Scheme_Compiled_Let_Value *)body;
if (!retry_start)
retry_start = pre_body;
size_before_opt = body_info->size;
value = scheme_optimize_expr(pre_body->value, rhs_info);
if ((pre_body->count == 1)
&& SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(pre_body->value))
&& !scheme_optimize_is_used(body_info, pos)) {
if (!body_info->transitive_use) {
mzshort **tu;
int *tu_len;
tu = (mzshort **)scheme_malloc(sizeof(mzshort *) * head->count);
tu_len = (int *)scheme_malloc_atomic(sizeof(int) * head->count);
memset(tu_len, 0, sizeof(int) * head->count);
body_info->transitive_use = tu;
body_info->transitive_use_len = tu_len;
}
body_info->transitive_use_pos = pos + 1;
}
value = scheme_optimize_expr(pre_body->value, rhs_info);
pre_body->value = value;
body_info->transitive_use_pos = 0;
if (is_rec && !not_simply_let_star) {
/* Keep track of whether we can simplify to let*: */
if (scheme_optimize_any_uses(rhs_info, pos, head->count))
not_simply_let_star = 1;
}
/* Change (let-values ([(id ...) (values e ...)]) body)
to (let-values ([id e] ...) body) for simple e. */
if ((pre_body->count != 1)
&& is_values_apply(value)
&& scheme_omittable_expr(value, pre_body->count)) {
Scheme_Compiled_Let_Value *naya;
Scheme_Object *rest = pre_body->body;
int *new_flags;
int cnt = pre_body->count;
while (cnt--) {
naya = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value);
naya->so.type = scheme_compiled_let_value_type;
naya->body = rest;
naya->count = 1;
naya->position = pre_body->position + cnt;
new_flags = (int *)scheme_malloc_atomic(sizeof(int));
new_flags[0] = pre_body->flags[cnt];
naya->flags = new_flags;
rest = (Scheme_Object *)naya;
}
naya = (Scheme_Compiled_Let_Value *)rest;
unpack_values_application(value, naya);
if (prev_body)
prev_body->body = (Scheme_Object *)naya;
else
head->body = (Scheme_Object *)naya;
head->num_clauses += (pre_body->count - 1);
i += (pre_body->count - 1);
pre_body = naya;
body = (Scheme_Object *)naya;
value = pre_body->value;
}
if ((pre_body->count == 1)
&& !(pre_body->flags[0] & SCHEME_WAS_SET_BANGED)) {
if (SAME_TYPE(SCHEME_TYPE(value), scheme_local_type)) {
/* Don't optimize reference to a local binding
that's not available yet, or that mutable. */
that's not available yet, or that's mutable. */
int vpos;
vpos = SCHEME_LOCAL_POS(value);
if ((vpos < head->count) && (vpos >= pos))
@ -2729,6 +2823,9 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
}
}
if (!retry_start)
retry_start = pre_body;
/* Re-optimize to inline letrec bindings? */
if (is_rec
&& !body_info->letrec_not_twice
@ -2761,6 +2858,13 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
Scheme_Object *self_value;
int sz;
if ((clv->count == 1)
&& body_info->transitive_use
&& !scheme_optimize_is_used(body_info, clv->position)) {
body_info->transitive_use[clv->position] = NULL;
body_info->transitive_use_pos = clv->position + 1;
}
cl = SCHEME_CDR(cl);
self_value = SCHEME_CDR(cl_first);
@ -2779,6 +2883,12 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
body_info->letrec_not_twice = 0;
clv->value = value;
if (!(clv->flags[0] & SCHEME_WAS_SET_BANGED)) {
scheme_optimize_propagate(body_info, clv->position, value);
}
body_info->transitive_use_pos = 0;
}
if (clv == pre_body)
break;
@ -2796,6 +2906,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
}
pos += pre_body->count;
prev_body = pre_body;
body = pre_body->body;
info->size += 1;
}
@ -2812,37 +2923,41 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
info->preserves_marks = body_info->preserves_marks;
/* Clear used flags where possible */
if (all_simple) {
body = head->body;
pos = 0;
for (i = head->num_clauses; i--; ) {
int used = 0, j;
pre_body = (Scheme_Compiled_Let_Value *)body;
for (j = pre_body->count; j--; ) {
if (scheme_optimize_is_used(body_info, pos+j)) {
used = 1;
break;
}
body = head->body;
pos = 0;
for (i = head->num_clauses; i--; ) {
int used = 0, j;
pre_body = (Scheme_Compiled_Let_Value *)body;
for (j = pre_body->count; j--; ) {
if (scheme_optimize_is_used(body_info, pos+j)) {
used = 1;
break;
}
if (!used
&& scheme_omittable_expr(pre_body->value, pre_body->count)) {
for (j = pre_body->count; j--; ) {
if (pre_body->flags[j] & SCHEME_WAS_USED) {
pre_body->flags[j] -= SCHEME_WAS_USED;
}
}
} else {
for (j = pre_body->count; j--; ) {
pre_body->flags[j] |= SCHEME_WAS_USED;
}
}
pos += pre_body->count;
body = pre_body->body;
}
if (!used
&& scheme_omittable_expr(pre_body->value, pre_body->count)) {
for (j = pre_body->count; j--; ) {
if (pre_body->flags[j] & SCHEME_WAS_USED) {
pre_body->flags[j] -= SCHEME_WAS_USED;
}
}
} else {
for (j = pre_body->count; j--; ) {
pre_body->flags[j] |= SCHEME_WAS_USED;
}
}
pos += pre_body->count;
body = pre_body->body;
}
scheme_optimize_info_done(body_info);
if (is_rec && !not_simply_let_star) {
/* We can simplify letrec to let* */
SCHEME_LET_FLAGS(head) -= SCHEME_LET_RECURSIVE;
SCHEME_LET_FLAGS(head) |= SCHEME_LET_STAR;
}
return form;
}
@ -2974,7 +3089,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
int i, pos, opos, rpos, recbox, num_rec_procs = 0, extra_alloc;
int rec_proc_nonapply = 0;
int max_let_depth = 0;
int resolve_phase;
int resolve_phase, num_skips;
Scheme_Object **lifted_recs;
/* Find body: */
@ -2992,35 +3107,44 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) {
int is_proc, is_lift;
is_proc = scheme_is_compiled_procedure(clv->value, 1, 1);
if (is_proc)
is_lift = 0;
else
is_lift = is_liftable(clv->value, head->count, 5);
if (!is_proc && !is_lift) {
recbox = 1;
break;
if ((clv->count == 1)
&& !(clv->flags[0] & SCHEME_WAS_USED)) {
/* skip */
} else {
if (!is_lift) {
/* is_proc must be true ... */
int j;
if (clv->count == 1)
is_proc = scheme_is_compiled_procedure(clv->value, 1, 1);
else
is_proc = 0;
for (j = 0; j < clv->count; j++) {
if (clv->flags[j] & SCHEME_WAS_SET_BANGED) {
recbox = 1;
break;
}
}
if (recbox)
break;
if (is_proc)
is_lift = 0;
else
is_lift = is_liftable(clv->value, head->count, 5);
if (!is_proc && !is_lift) {
recbox = 1;
break;
} else {
if (!is_lift) {
/* is_proc must be true ... */
int j;
if (scheme_is_compiled_procedure(clv->value, 0, 0)) {
num_rec_procs++;
if (!(clv->flags[0] & SCHEME_WAS_ONLY_APPLIED))
rec_proc_nonapply = 1;
for (j = 0; j < clv->count; j++) {
if (clv->flags[j] & SCHEME_WAS_SET_BANGED) {
recbox = 1;
break;
}
}
if (recbox)
break;
if (scheme_is_compiled_procedure(clv->value, 0, 0)) {
num_rec_procs++;
if (!(clv->flags[0] & SCHEME_WAS_ONLY_APPLIED))
rec_proc_nonapply = 1;
}
}
}
}
}
}
@ -3084,11 +3208,15 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
}
lifts_frame_size = frame_size;
if ((clv->flags[0] & SCHEME_WAS_ONLY_APPLIED)
&& SAME_TYPE(SCHEME_TYPE(clv->value), scheme_compiled_unclosed_procedure_type))
le = scheme_resolve_closure_compilation(clv->value, linfo, 1, 1, 0, NULL);
else
le = scheme_resolve_expr(clv->value, linfo);
if (skips[i]) {
le = scheme_void;
} else {
if ((clv->flags[0] & SCHEME_WAS_ONLY_APPLIED)
&& SAME_TYPE(SCHEME_TYPE(clv->value), scheme_compiled_unclosed_procedure_type))
le = scheme_resolve_closure_compilation(clv->value, linfo, 1, 1, 0, NULL);
else
le = scheme_resolve_expr(clv->value, linfo);
}
if (max_let_depth < linfo->max_let_depth + frame_size)
max_let_depth = linfo->max_let_depth + frame_size;
@ -3189,6 +3317,13 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
}
}
num_skips = 0;
clv = (Scheme_Compiled_Let_Value *)head->body;
for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) {
if ((clv->count == 1) && !(clv->flags[0] & SCHEME_WAS_USED))
num_skips++;
}
/* First assume that all letrec-bound procedures can be lifted to empty closures.
Then try assuming that all letrec-bound procedures can be at least lifted.
Then fall back to assuming no lifts. */
@ -3201,10 +3336,10 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
resolve_phase = 2;
if (resolve_phase < 2) {
linfo = scheme_resolve_info_extend(info, head->count - num_rec_procs, head->count, head->count);
linfo = scheme_resolve_info_extend(info, head->count - num_rec_procs - num_skips, head->count, head->count);
lifted_recs = MALLOC_N(Scheme_Object *, num_rec_procs);
} else {
linfo = scheme_resolve_info_extend(info, head->count, head->count, head->count);
linfo = scheme_resolve_info_extend(info, head->count - num_skips, head->count, head->count);
lifted_recs = NULL;
}
@ -3218,38 +3353,46 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) {
int j;
for (j = 0; j < clv->count; j++) {
int p, skip;
Scheme_Object *lift;
skip = 0;
if (num_rec_procs && scheme_is_compiled_procedure(clv->value, 0, 0)) {
if (resolve_phase == 0) {
lift = scheme_resolve_generate_stub_closure();
lifted_recs[rpos] = lift;
p = 0;
} else if (resolve_phase == 1) {
lift = scheme_resolve_generate_stub_lift();
lifted_recs[rpos] = lift;
p = 0;
} else {
lift = NULL;
p = rpos;
}
rpos++;
} else {
p = pos++;
lift = NULL;
}
scheme_resolve_info_add_mapping(linfo, opos, p,
((recbox
|| (clv->flags[j] & SCHEME_WAS_SET_BANGED))
? SCHEME_INFO_BOXED
: 0),
lift);
if ((clv->count == 1) && !(clv->flags[0] & SCHEME_WAS_USED)) {
/* skipped */
scheme_resolve_info_add_mapping(linfo, opos, 0, 0, NULL);
opos++;
} else {
for (j = 0; j < clv->count; j++) {
int p, skip;
Scheme_Object *lift;
skip = 0;
if (num_rec_procs
&& (clv->count == 1)
&& scheme_is_compiled_procedure(clv->value, 0, 0)) {
if (resolve_phase == 0) {
lift = scheme_resolve_generate_stub_closure();
lifted_recs[rpos] = lift;
p = 0;
} else if (resolve_phase == 1) {
lift = scheme_resolve_generate_stub_lift();
lifted_recs[rpos] = lift;
p = 0;
} else {
lift = NULL;
p = rpos;
}
rpos++;
} else {
p = pos++;
lift = NULL;
}
scheme_resolve_info_add_mapping(linfo, opos, p,
((recbox
|| (clv->flags[j] & SCHEME_WAS_SET_BANGED))
? SCHEME_INFO_BOXED
: 0),
lift);
opos++;
}
}
}
@ -3265,7 +3408,10 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
rpos = 0; opos = 0;
converted = 0;
for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) {
if (scheme_is_compiled_procedure(clv->value, 0, 0)) {
if ((clv->count == 1) && !(clv->flags[0] & SCHEME_WAS_USED)) {
/* skipped */
} else if ((clv->count == 1)
&& scheme_is_compiled_procedure(clv->value, 0, 0)) {
Scheme_Object *lift, *old_lift;
int old_convert_count;
@ -3310,7 +3456,9 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
clv = (Scheme_Compiled_Let_Value *)head->body;
rpos = 0; opos = 0;
for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) {
if (scheme_is_compiled_procedure(clv->value, 0, 0)) {
if ((clv->count == 1) && !(clv->flags[0] & SCHEME_WAS_USED)) {
/* skipped */
} else if ((clv->count == 1) && scheme_is_compiled_procedure(clv->value, 0, 0)) {
Scheme_Object *lift;
lift = lifted_recs[rpos];
if (is_closed_reference(lift)) {
@ -3360,72 +3508,78 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
clv = (Scheme_Compiled_Let_Value *)head->body;
rpos = 0; opos = 0;
for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) {
int isproc;
Scheme_Object *expr;
if (!clv->value)
isproc = 1;
else
isproc = scheme_is_compiled_procedure(clv->value, 0, 0);
if (num_rec_procs && isproc) {
if (!lifted_recs) {
expr = scheme_resolve_closure_compilation(clv->value, val_linfo, 0, 0, 0, NULL);
letrec->procs[rpos++] = expr;
} else {
if (!is_closed_reference(lifted_recs[rpos])) {
/* Side-effect is to install lifted function: */
(void)scheme_resolve_closure_compilation(clv->value, val_linfo, 1, 1, 0, lifted_recs[rpos]);
}
rpos++;
}
if ((clv->count == 1) && !(clv->flags[0] & SCHEME_WAS_USED)) {
/* skipped */
} else {
int j;
Scheme_Object *one_lifted;
expr = scheme_resolve_expr(clv->value, val_linfo);
lv = MALLOC_ONE_TAGGED(Scheme_Let_Value);
if (last)
last->body = (Scheme_Object *)lv;
else if (last_body)
SCHEME_CDR(last_body) = (Scheme_Object *)lv;
int isproc;
Scheme_Object *expr;
if (!clv->value)
isproc = 1;
else if (clv->count == 1)
isproc = scheme_is_compiled_procedure(clv->value, 0, 0);
else
first = (Scheme_Object *)lv;
last = lv;
last_body = NULL;
lv->iso.so.type = scheme_let_value_type;
lv->value = expr;
if (clv->count) {
int li;
li = scheme_resolve_info_lookup(linfo, clv->position, NULL, NULL, 0);
lv->position = li;
} else
lv->position = 0;
lv->count = clv->count;
SCHEME_LET_AUTOBOX(lv) = recbox;
for (j = lv->count; j--; ) {
if (!recbox
&& (scheme_resolve_info_flags(linfo, opos + j, &one_lifted) & SCHEME_INFO_BOXED)) {
GC_CAN_IGNORE Scheme_Object *pos;
pos = scheme_make_integer(lv->position + j);
if (SCHEME_LET_FLAGS(head) & (SCHEME_LET_STAR | SCHEME_LET_RECURSIVE)) {
/* For let* or a let*-like letrec, we need to insert the boxes after each evaluation. */
Scheme_Object *boxenv, *pr;
pr = scheme_make_pair(pos, scheme_false);
boxenv = scheme_make_syntax_resolved(BOXENV_EXPD, pr);
if (last)
last->body = boxenv;
else
SCHEME_CDR(last_body) = boxenv;
last = NULL;
last_body = pr;
} else {
/* For regular let, delay the boxing until all RHSs are
evaluated. */
boxes = scheme_make_pair(pos, boxes);
isproc = 0;
if (num_rec_procs && isproc) {
if (!lifted_recs) {
expr = scheme_resolve_closure_compilation(clv->value, val_linfo, 0, 0, 0, NULL);
letrec->procs[rpos++] = expr;
} else {
if (!is_closed_reference(lifted_recs[rpos])) {
/* Side-effect is to install lifted function: */
(void)scheme_resolve_closure_compilation(clv->value, val_linfo, 1, 1, 0, lifted_recs[rpos]);
}
}
rpos++;
}
} else {
int j;
Scheme_Object *one_lifted;
expr = scheme_resolve_expr(clv->value, val_linfo);
lv = MALLOC_ONE_TAGGED(Scheme_Let_Value);
if (last)
last->body = (Scheme_Object *)lv;
else if (last_body)
SCHEME_CDR(last_body) = (Scheme_Object *)lv;
else
first = (Scheme_Object *)lv;
last = lv;
last_body = NULL;
lv->iso.so.type = scheme_let_value_type;
lv->value = expr;
if (clv->count) {
int li;
li = scheme_resolve_info_lookup(linfo, clv->position, NULL, NULL, 0);
lv->position = li;
} else
lv->position = 0;
lv->count = clv->count;
SCHEME_LET_AUTOBOX(lv) = recbox;
for (j = lv->count; j--; ) {
if (!recbox
&& (scheme_resolve_info_flags(linfo, opos + j, &one_lifted) & SCHEME_INFO_BOXED)) {
GC_CAN_IGNORE Scheme_Object *pos;
pos = scheme_make_integer(lv->position + j);
if (SCHEME_LET_FLAGS(head) & (SCHEME_LET_STAR | SCHEME_LET_RECURSIVE)) {
/* For let* or a let*-like letrec, we need to insert the boxes after each evaluation. */
Scheme_Object *boxenv, *pr;
pr = scheme_make_pair(pos, scheme_false);
boxenv = scheme_make_syntax_resolved(BOXENV_EXPD, pr);
if (last)
last->body = boxenv;
else
SCHEME_CDR(last_body) = boxenv;
last = NULL;
last_body = pr;
} else {
/* For regular let, delay the boxing until all RHSs are
evaluated. */
boxes = scheme_make_pair(pos, boxes);
}
}
}
}
}
opos += clv->count;
@ -3457,20 +3611,20 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
else
first = body;
if (head->count + extra_alloc) {
if (head->count + extra_alloc - num_skips) {
Scheme_Let_Void *lvd;
lvd = MALLOC_ONE_TAGGED(Scheme_Let_Void);
lvd->iso.so.type = scheme_let_void_type;
lvd->body = first;
lvd->count = head->count + extra_alloc;
lvd->count = head->count + extra_alloc - num_skips;
SCHEME_LET_AUTOBOX(lvd) = recbox;
first = (Scheme_Object *)lvd;
}
if (info->max_let_depth < linfo->max_let_depth + head->count)
info->max_let_depth = linfo->max_let_depth + head->count;
if (info->max_let_depth < linfo->max_let_depth + head->count - num_skips + extra_alloc)
info->max_let_depth = linfo->max_let_depth + head->count - num_skips + extra_alloc;
return first;
}