* optimized symbol calls using the symbol-function field.

* added error checks for applying nonprocedures.
This commit is contained in:
Abdulaziz Ghuloum 2007-02-25 21:29:28 -05:00
parent 87d8d5a5dd
commit de7c43a16b
14 changed files with 731 additions and 144 deletions

View File

@ -3383,3 +3383,434 @@ Words allocated: 94867544
Words reclaimed: 0 Words reclaimed: 0
Elapsed time...: 1846 ms (User: 1589 ms; System: 254 ms) Elapsed time...: 1846 ms (User: 1589 ms; System: 254 ms)
Elapsed GC time: 1145 ms (CPU: 1161 in 360 collections.) Elapsed GC time: 1145 ms (CPU: 1161 in 360 collections.)
****************************
Benchmarking Larceny-r6rs on Sun Feb 25 20:21:22 EST 2007 under Darwin Vesuvius.local 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
Testing fib under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 0
Words reclaimed: 0
Elapsed time...: 1778 ms (User: 1777 ms; System: 1 ms)
Elapsed GC time: 0 ms (CPU: 0 in 0 collections.)
****************************
Benchmarking Larceny-r6rs on Sun Feb 25 20:23:46 EST 2007 under Darwin Vesuvius.local 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
Testing peval under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 34340444
Words reclaimed: 0
Elapsed time...: 1255 ms (User: 1249 ms; System: 7 ms)
Elapsed GC time: 58 ms (CPU: 58 in 131 collections.)
****************************
Benchmarking Larceny-r6rs on Sun Feb 25 20:24:12 EST 2007 under Darwin Vesuvius.local 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
Testing paraffins under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 201324942
Words reclaimed: 0
Elapsed time...: 4260 ms (User: 3750 ms; System: 509 ms)
Elapsed GC time: 2433 ms (CPU: 2432 in 768 collections.)
****************************
Benchmarking Larceny-r6rs on Sun Feb 25 20:24:38 EST 2007 under Darwin Vesuvius.local 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
Testing paraffins under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 201324942
Words reclaimed: 0
Elapsed time...: 4265 ms (User: 3750 ms; System: 514 ms)
Elapsed GC time: 2428 ms (CPU: 2423 in 768 collections.)
****************************
Benchmarking Larceny-r6rs on Sun Feb 25 20:37:49 EST 2007 under Darwin Vesuvius.local 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
Testing slatex under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 4194150
Words reclaimed: 0
Elapsed time...: 1881 ms (User: 546 ms; System: 751 ms)
Elapsed GC time: 10 ms (CPU: 11 in 16 collections.)
****************************
Benchmarking Larceny-r6rs on Sun Feb 25 20:38:10 EST 2007 under Darwin Vesuvius.local 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
Testing parsing under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 100923902
Words reclaimed: 0
Elapsed time...: 6573 ms (User: 6503 ms; System: 69 ms)
Elapsed GC time: 284 ms (CPU: 285 in 385 collections.)
****************************
Benchmarking Larceny-r6rs on Sun Feb 25 20:39:27 EST 2007 under Darwin Vesuvius.local 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
Testing lattice under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 19398398
Words reclaimed: 0
Elapsed time...: 1678 ms (User: 1675 ms; System: 3 ms)
Elapsed GC time: 35 ms (CPU: 33 in 74 collections.)
****************************
Benchmarking Larceny-r6rs on Sun Feb 25 20:40:30 EST 2007 under Darwin Vesuvius.local 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
Testing destruc under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 43253750
Words reclaimed: 0
Elapsed time...: 1037 ms (User: 1034 ms; System: 3 ms)
Elapsed GC time: 65 ms (CPU: 61 in 165 collections.)
****************************
Benchmarking Larceny-r6rs on Sun Feb 25 20:51:24 EST 2007 under Darwin Vesuvius.local 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
Testing destruc under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 43253750
Words reclaimed: 0
Elapsed time...: 1038 ms (User: 1034 ms; System: 4 ms)
Elapsed GC time: 62 ms (CPU: 60 in 165 collections.)
****************************
Benchmarking Larceny-r6rs on Sun Feb 25 20:56:32 EST 2007 under Darwin Vesuvius.local 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
Testing destruc under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 43253750
Words reclaimed: 0
Elapsed time...: 1036 ms (User: 1033 ms; System: 3 ms)
Elapsed GC time: 65 ms (CPU: 62 in 165 collections.)
****************************
Benchmarking Larceny-r6rs on Sun Feb 25 20:56:58 EST 2007 under Darwin Vesuvius.local 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
Testing dderiv under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 244055776
Words reclaimed: 0
Elapsed time...: 1899 ms (User: 1888 ms; System: 10 ms)
Elapsed GC time: 284 ms (CPU: 328 in 931 collections.)
****************************
Benchmarking Larceny-r6rs on Sun Feb 25 20:57:13 EST 2007 under Darwin Vesuvius.local 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
Testing dderiv under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 244055776
Words reclaimed: 0
Elapsed time...: 1887 ms (User: 1877 ms; System: 10 ms)
Elapsed GC time: 327 ms (CPU: 323 in 931 collections.)
****************************
Benchmarking Larceny-r6rs on Sun Feb 25 20:57:37 EST 2007 under Darwin Vesuvius.local 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
Testing sum1 under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 6553374
Words reclaimed: 0
Elapsed time...: 3512 ms (User: 2062 ms; System: 1440 ms)
Elapsed GC time: 6 ms (CPU: 12 in 25 collections.)
****************************
Benchmarking Larceny-r6rs on Sun Feb 25 20:58:03 EST 2007 under Darwin Vesuvius.local 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
Testing sumfp under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 400031744
Words reclaimed: 0
Elapsed time...: 1804 ms (User: 1798 ms; System: 6 ms)
Elapsed GC time: 544 ms (CPU: 534 in 1526 collections.)
****************************
Benchmarking Larceny-r6rs on Sun Feb 25 20:59:25 EST 2007 under Darwin Vesuvius.local 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
Testing sumloop under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 0
Words reclaimed: 0
Elapsed time...: 804 ms (User: 803 ms; System: 1 ms)
Elapsed GC time: 0 ms (CPU: 0 in 0 collections.)
****************************
Benchmarking Larceny-r6rs on Sun Feb 25 20:59:28 EST 2007 under Darwin Vesuvius.local 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
Testing sumloop under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 0
Words reclaimed: 0
Elapsed time...: 804 ms (User: 803 ms; System: 0 ms)
Elapsed GC time: 0 ms (CPU: 0 in 0 collections.)
****************************
Benchmarking Larceny-r6rs on Sun Feb 25 20:59:32 EST 2007 under Darwin Vesuvius.local 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
Testing sumloop under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 0
Words reclaimed: 0
Elapsed time...: 804 ms (User: 803 ms; System: 0 ms)
Elapsed GC time: 0 ms (CPU: 0 in 0 collections.)
****************************
Benchmarking Larceny-r6rs on Sun Feb 25 21:00:43 EST 2007 under Darwin Vesuvius.local 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
Testing gcbench under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
> The garbage collector should touch about 32 megabytes of heap storage.
The use of more or less memory will skew the results.
Garbage Collector Test
Stretching memory with a binary tree of depth 18
Total memory available= ???????? bytes Free memory= ???????? bytes
GCBench: Main
Creating a long-lived binary tree of depth 16
Creating a long-lived array of 524284 inexact reals
Total memory available= ???????? bytes Free memory= ???????? bytes
Creating 33824 trees of depth 4
GCBench: Top down construction
GCBench: Bottom up construction
Creating 8256 trees of depth 6
GCBench: Top down construction
GCBench: Bottom up construction
Creating 2052 trees of depth 8
GCBench: Top down construction
GCBench: Bottom up construction
Creating 512 trees of depth 10
GCBench: Top down construction
GCBench: Bottom up construction
Creating 128 trees of depth 12
GCBench: Top down construction
GCBench: Bottom up construction
Creating 32 trees of depth 14
GCBench: Top down construction
GCBench: Bottom up construction
Creating 8 trees of depth 16
GCBench: Top down construction
GCBench: Bottom up construction
Total memory available= ???????? bytes Free memory= ???????? bytes
Words allocated: 94867544
Words reclaimed: 0
Elapsed time...: 1823 ms (User: 1585 ms; System: 235 ms)
Elapsed GC time: 1139 ms (CPU: 1131 in 360 collections.)
****************************
Benchmarking Larceny-r6rs on Sun Feb 25 21:02:33 EST 2007 under Darwin Vesuvius.local 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
Testing puzzle under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 8126378
Words reclaimed: 0
Elapsed time...: 1947 ms (User: 1804 ms; System: 143 ms)
Elapsed GC time: 14 ms (CPU: 12 in 31 collections.)
****************************
Benchmarking Larceny-r6rs on Sun Feb 25 21:05:18 EST 2007 under Darwin Vesuvius.local 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
Testing puzzle under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 8126378
Words reclaimed: 0
Elapsed time...: 1947 ms (User: 1804 ms; System: 142 ms)
Elapsed GC time: 9 ms (CPU: 8 in 31 collections.)

Binary file not shown.

View File

@ -48,13 +48,15 @@ typedef struct{
#define meta_data 2 #define meta_data 2
#define meta_weak 3 #define meta_weak 3
#define meta_pair 4 #define meta_pair 4
#define meta_count 5 #define meta_symbol 5
#define meta_count 6
static int extension_amount[meta_count] = { static int extension_amount[meta_count] = {
1 * pagesize, 1 * pagesize,
1 * pagesize, 1 * pagesize,
1 * pagesize, 1 * pagesize,
1 * pagesize, 1 * pagesize,
1 * pagesize,
1 * pagesize 1 * pagesize
}; };
@ -63,11 +65,10 @@ static unsigned int meta_mt[meta_count] = {
code_mt, code_mt,
data_mt, data_mt,
weak_pairs_mt, weak_pairs_mt,
pointers_mt pointers_mt,
symbols_mt
}; };
typedef struct gc_t{ typedef struct gc_t{
meta_t meta[generation_count][meta_count]; meta_t meta[generation_count][meta_count];
qupages_t* queues [meta_count]; qupages_t* queues [meta_count];
@ -112,7 +113,6 @@ meta_alloc_extending(int size, int old_gen, gc_t* gc, int meta_id){
x += wordsize; x += wordsize;
} }
} }
ikp mem = ik_mmap_typed( ikp mem = ik_mmap_typed(
mapsize, mapsize,
meta_mt[meta_id] | next_gen_tag[old_gen], meta_mt[meta_id] | next_gen_tag[old_gen],
@ -149,6 +149,12 @@ gc_alloc_new_ptr(int size, int old_gen, gc_t* gc){
return meta_alloc(size, old_gen, gc, meta_ptrs); return meta_alloc(size, old_gen, gc, meta_ptrs);
} }
static inline ikp
gc_alloc_new_symbol(int old_gen, gc_t* gc){
assert(symbol_size == align(symbol_size));
return meta_alloc(symbol_size, old_gen, gc, meta_symbol);
}
static inline ikp static inline ikp
gc_alloc_new_pair(int old_gen, gc_t* gc){ gc_alloc_new_pair(int old_gen, gc_t* gc){
return meta_alloc(pair_size, old_gen, gc, meta_pair); return meta_alloc(pair_size, old_gen, gc, meta_pair);
@ -911,9 +917,6 @@ add_object_proc(gc_t* gc, ikp x)
/* already moved */ /* already moved */
return ref(x, wordsize-tag); return ref(x, wordsize-tag);
} }
if(x == (ikp)0x07a3f035){
fprintf(stderr, "FST=0x%08x\n", (int)fst);
}
unsigned int t = gc->segment_vector[page_index(x)]; unsigned int t = gc->segment_vector[page_index(x)];
int gen = t & gen_mask; int gen = t & gen_mask;
if(gen > gc->collect_gen){ if(gen > gc->collect_gen){
@ -925,13 +928,16 @@ add_object_proc(gc_t* gc, ikp x)
return y; return y;
} }
else if(tag == symbol_tag){ else if(tag == symbol_tag){
ikp y = gc_alloc_new_ptr(symbol_size, gen, gc) + symbol_tag; //ikp y = gc_alloc_new_ptr(align(symbol_size),gen, gc) + symbol_tag;
ref(y, off_symbol_string) = ref(x, off_symbol_string); ikp y = gc_alloc_new_symbol(gen, gc) + symbol_tag;
ref(y, off_symbol_ustring) = ref(x, off_symbol_ustring); ref(y, off_symbol_string) = ref(x, off_symbol_string);
ref(y, off_symbol_value) = ref(x, off_symbol_value); ref(y, off_symbol_ustring) = ref(x, off_symbol_ustring);
ref(y, off_symbol_plist) = ref(x, off_symbol_plist); ref(y, off_symbol_value) = ref(x, off_symbol_value);
ref(y, off_symbol_plist) = ref(x, off_symbol_plist);
ref(y, off_symbol_system_value) = ref(x, off_symbol_system_value); ref(y, off_symbol_system_value) = ref(x, off_symbol_system_value);
ref(y, off_symbol_system_plist) = ref(x, off_symbol_system_plist); ref(y, off_symbol_code) = ref(x, off_symbol_code);
ref(y, off_symbol_errcode) = ref(x, off_symbol_errcode);
ref(y, off_symbol_unused) = 0;
ref(x, -symbol_tag) = forward_ptr; ref(x, -symbol_tag) = forward_ptr;
ref(x, wordsize-symbol_tag) = y; ref(x, wordsize-symbol_tag) = y;
#if accounting #if accounting
@ -1202,6 +1208,26 @@ collect_loop(gc_t* gc){
} while(qu); } while(qu);
} }
} }
{ /* scan the pending symbol pages */
qupages_t* qu = gc->queues[meta_symbol];
if(qu){
done = 0;
gc->queues[meta_symbol] = 0;
do{
ikp p = qu->p;
ikp q = qu->q;
while(p < q){
ref(p,0) = add_object(gc, ref(p,0), "symbols");
p += wordsize;
}
qupages_t* next = qu->next;
ik_free(qu, sizeof(qupages_t));
qu = next;
} while(qu);
}
}
{ /* scan the pending code objects */ { /* scan the pending code objects */
qupages_t* codes = gc->queues[meta_code]; qupages_t* codes = gc->queues[meta_code];
if(codes){ if(codes){
@ -1240,6 +1266,23 @@ collect_loop(gc_t* gc){
} while (p < q); } while (p < q);
} }
} }
for(i=0; i<=gc->collect_gen; i++){
meta_t* meta = &gc->meta[i][meta_symbol];
ikp p = meta->aq;
ikp q = meta->ap;
if(p < q){
done = 0;
do{
meta->aq = q;
while(p < q){
ref(p,0) = add_object(gc, ref(p,0), "sym");
p += wordsize;
}
p = meta->aq;
q = meta->ap;
} while (p < q);
}
}
for(i=0; i<=gc->collect_gen; i++){ for(i=0; i<=gc->collect_gen; i++){
meta_t* meta = &gc->meta[i][meta_ptrs]; meta_t* meta = &gc->meta[i][meta_ptrs];
ikp p = meta->aq; ikp p = meta->aq;
@ -1289,6 +1332,15 @@ collect_loop(gc_t* gc){
p += wordsize; p += wordsize;
} }
} }
for(i=0; i<=gc->collect_gen; i++){
meta_t* meta = &gc->meta[i][meta_symbol];
ikp p = meta->ap;
ikp q = meta->ep;
while(p < q){
ref(p, 0) = 0;
p += wordsize;
}
}
for(i=0; i<=gc->collect_gen; i++){ for(i=0; i<=gc->collect_gen; i++){
meta_t* meta = &gc->meta[i][meta_ptrs]; meta_t* meta = &gc->meta[i][meta_ptrs];
ikp p = meta->ap; ikp p = meta->ap;
@ -1508,6 +1560,11 @@ scan_dirty_pages(gc_t* gc){
dirty_vec = pcb->dirty_vector; dirty_vec = pcb->dirty_vector;
segment_vec = pcb->segment_vector; segment_vec = pcb->segment_vector;
} }
else if(type == symbols_type){
scan_dirty_pointers_page(gc, i, mask);
dirty_vec = pcb->dirty_vector;
segment_vec = pcb->segment_vector;
}
else if (type == weak_pairs_type){ else if (type == weak_pairs_type){
if((t & gen_mask) > collect_gen){ if((t & gen_mask) > collect_gen){
scan_dirty_weak_pointers_page(gc, i, mask); scan_dirty_weak_pointers_page(gc, i, mask);
@ -1580,7 +1637,8 @@ fix_new_pages(gc_t* gc){
segment_vec[i] = t & ~new_gen_mask; segment_vec[i] = t & ~new_gen_mask;
int page_gen = t & old_gen_mask; int page_gen = t & old_gen_mask;
if(((t & type_mask) == pointers_type) || if(((t & type_mask) == pointers_type) ||
((t & type_mask) == weak_pairs_type)){ ((t & type_mask) == symbols_type) ||
((t & type_mask) == weak_pairs_type) ){
ikp p = (ikp)(i << pageshift); ikp p = (ikp)(i << pageshift);
unsigned int d = 0; unsigned int d = 0;
int j; int j;

View File

@ -113,14 +113,18 @@
#define disp_symbol_value 8 #define disp_symbol_value 8
#define disp_symbol_plist 12 #define disp_symbol_plist 12
#define disp_symbol_system_value 16 #define disp_symbol_system_value 16
#define disp_symbol_system_plist 20 #define disp_symbol_code 20
#define symbol_size 24 #define disp_symbol_errcode 24
#define disp_symbol_unused 28
#define symbol_size 32
#define off_symbol_string (disp_symbol_string - symbol_tag) #define off_symbol_string (disp_symbol_string - symbol_tag)
#define off_symbol_ustring (disp_symbol_ustring - symbol_tag) #define off_symbol_ustring (disp_symbol_ustring - symbol_tag)
#define off_symbol_value (disp_symbol_value - symbol_tag) #define off_symbol_value (disp_symbol_value - symbol_tag)
#define off_symbol_plist (disp_symbol_plist - symbol_tag) #define off_symbol_plist (disp_symbol_plist - symbol_tag)
#define off_symbol_system_value (disp_symbol_system_value - symbol_tag) #define off_symbol_system_value (disp_symbol_system_value - symbol_tag)
#define off_symbol_system_plist (disp_symbol_system_plist - symbol_tag) #define off_symbol_code (disp_symbol_code - symbol_tag)
#define off_symbol_errcode (disp_symbol_errcode - symbol_tag)
#define off_symbol_unused (disp_symbol_unused - symbol_tag)
#define closure_tag 3 #define closure_tag 3
#define closure_mask 7 #define closure_mask 7

View File

@ -50,7 +50,9 @@ ik_make_symbol(ikp str, ikp ustr, ikpcb* pcb){
ref(sym, off_symbol_value) = unbound_object; ref(sym, off_symbol_value) = unbound_object;
ref(sym, off_symbol_plist) = null_object; ref(sym, off_symbol_plist) = null_object;
ref(sym, off_symbol_system_value) = str; ref(sym, off_symbol_system_value) = str;
ref(sym, off_symbol_system_plist) = null_object; ref(sym, off_symbol_code) = 0;
ref(sym, off_symbol_errcode) = 0;
ref(sym, off_symbol_unused) = 0;
return sym; return sym;
} }

View File

@ -31,6 +31,7 @@ extern int hash_table_count;
#define data_type 0x00000400 #define data_type 0x00000400
#define code_type 0x00000500 #define code_type 0x00000500
#define weak_pairs_type 0x00000600 #define weak_pairs_type 0x00000600
#define symbols_type 0x00000700
#define scannable_tag 0x00001000 #define scannable_tag 0x00001000
#define unscannable_tag 0x00000000 #define unscannable_tag 0x00000000
@ -42,6 +43,7 @@ extern int hash_table_count;
#define mainheap_mt (mainheap_type | unscannable_tag | retain_tag) #define mainheap_mt (mainheap_type | unscannable_tag | retain_tag)
#define mainstack_mt (mainstack_type | unscannable_tag | retain_tag) #define mainstack_mt (mainstack_type | unscannable_tag | retain_tag)
#define pointers_mt (pointers_type | scannable_tag | dealloc_tag) #define pointers_mt (pointers_type | scannable_tag | dealloc_tag)
#define symbols_mt (symbols_type | scannable_tag | dealloc_tag)
#define data_mt (data_type | unscannable_tag | dealloc_tag) #define data_mt (data_type | unscannable_tag | dealloc_tag)
#define code_mt (code_type | scannable_tag | dealloc_tag) #define code_mt (code_type | scannable_tag | dealloc_tag)
#define weak_pairs_mt (weak_pairs_type | scannable_tag | dealloc_tag) #define weak_pairs_mt (weak_pairs_type | scannable_tag | dealloc_tag)

View File

@ -152,6 +152,9 @@ verify_page(unsigned char* p, unsigned char* base, unsigned int* svec, unsigned
else if(type == pointers_type){ else if(type == pointers_type){
return verify_pointers_page(p,s,d,base,svec,dvec); return verify_pointers_page(p,s,d,base,svec,dvec);
} }
else if(type == symbols_type){
return verify_pointers_page(p,s,d,base,svec,dvec);
}
else if(type == data_type){ else if(type == data_type){
/* nothing to do for data */ /* nothing to do for data */
return p+pagesize; return p+pagesize;

View File

@ -109,6 +109,42 @@
[movl (disp -4 %esp) %eax] [movl (disp -4 %esp) %eax]
[ret])) [ret]))
(asm-test 1
'([movl (obj (1 2)) (disp -4 %esp)]
[movl (obj car) %eax]
[movl (disp 14 %eax) %edi] ;;; symbol-value
[movl -4 %eax]
[jmp (disp -3 %edi)]))
(asm-test 1
'([movl (obj (1 2)) (disp -4 %esp)]
[movl (obj car) %eax]
[movl (disp 14 %eax) %edi] ;;; symbol-value
[movl (disp -3 %edi) %eax]
[movl %eax (disp 26 (obj car))]
[movl -4 %eax]
[jmp (disp 26 (obj car))]))
(asm-test 1
'([movl (obj (1 2)) (disp -4 %esp)]
[movl (obj car) %eax]
[movl (disp 14 %eax) %eax] ;;; symbol-value
[movl (disp -3 %eax) %eax]
[movl %eax (disp 26 (obj car))]
[movl -4 %eax]
[jmp (disp 26 (obj car))]))
(asm-test 1
'([movl (obj (1 2)) (disp -4 %esp)]
[movl -4 %eax]
[jmp (disp 26 (obj car))]))
(asm-test 1
'([movl (obj (1 2)) (disp -8 %esp)]
[movl -4 %eax]
[call (disp 26 (obj car))]
[ret]))
(printf "Happy Happy Joy Joy\n") (printf "Happy Happy Joy Joy\n")
(exit) (exit)

Binary file not shown.

View File

@ -47,6 +47,13 @@
(for-each check-var free*)] (for-each check-var free*)]
[else (error who "invalid closure ~s" x)])) [else (error who "invalid closure ~s" x)]))
;;; ;;;
(define (check-jmp-target x)
(unless (or (gensym? x)
(and (pair? x)
(eq? (car x) 'symbol-code)
(symbol? (cdr x))))
(error who "invalid jmp target")))
;;;
(define (Expr x) (define (Expr x)
(record-case x (record-case x
[(constant) (void)] [(constant) (void)]
@ -73,7 +80,7 @@
(Expr rator) (Expr rator)
(for-each Expr arg*)] (for-each Expr arg*)]
[(jmpcall label rator arg*) [(jmpcall label rator arg*)
(check-gensym label) (check-jmp-target label)
(Expr rator) (Expr rator)
(for-each Expr arg*)] (for-each Expr arg*)]
[(mvcall rator k) [(mvcall rator k)
@ -784,6 +791,13 @@
(prm 'sll (prm 'sra address (K pageshift)) (K wordshift))) (prm 'sll (prm 'sra address (K pageshift)) (K wordshift)))
(K 0) (K 0)
(K dirty-word))) (K dirty-word)))
(define (smart-dirty-vector-set addr what)
(record-case what
[(constant t)
(if (or (fixnum? t) (immediate? t))
(prm 'nop)
(dirty-vector-set addr))]
[else (dirty-vector-set addr)]))
(define (mem-assign v x i) (define (mem-assign v x i)
(tbind ([q v]) (tbind ([q v])
(tbind ([t (prm 'int+ x (K i))]) (tbind ([t (prm 'int+ x (K i))])
@ -802,6 +816,19 @@
[(primcall op arg*) [(primcall op arg*)
(case op (case op
[(nop) nop] [(nop) nop]
[($set-symbol-value!)
(tbind ([x (Value (car arg*))] [v (Value (cadr arg*))])
(seq*
(prm 'mset x (K (- disp-symbol-value symbol-tag)) v)
(prm 'mset x (K (- disp-symbol-function symbol-tag))
(prm 'mref x (K (- disp-symbol-error-function symbol-tag))))
(dirty-vector-set x)))]
[($init-symbol-function!)
(tbind ([x (Value (car arg*))] [v (Value (cadr arg*))])
(seq*
(prm 'mset x (K (- disp-symbol-function symbol-tag)) v)
(prm 'mset x (K (- disp-symbol-error-function symbol-tag)) v)
(dirty-vector-set x)))]
[(primitive-set! $set-symbol-value! $set-symbol-string! [(primitive-set! $set-symbol-value! $set-symbol-string!
$set-symbol-unique-string! $set-symbol-plist!) $set-symbol-unique-string! $set-symbol-plist!)
(let ([off (let ([off
@ -852,11 +879,14 @@
;;; card as the pair address, so no ;;; card as the pair address, so no
;;; adjustment is necessary as was the ;;; adjustment is necessary as was the
;;; case with vectors and records. ;;; case with vectors and records.
(make-conditional (make-shortcut
(tag-test x pair-mask pair-tag) (seq*
(make-seq (make-conditional
(tag-test x pair-mask pair-tag)
(prm 'nop)
(prm 'interrupt))
(prm 'mset x (K off) v) (prm 'mset x (K off) v)
(dirty-vector-set x)) (smart-dirty-vector-set x (cadr arg*)))
(Effect (Effect
(make-funcall (make-primref 'error) (make-funcall (make-primref 'error)
(list (K op) (K "~s is not a pair") x)))))))] (list (K op) (K "~s is not a pair") x)))))))]
@ -946,7 +976,7 @@
[(forcall op arg*) [(forcall op arg*)
(make-forcall op (map Value arg*))] (make-forcall op (map Value arg*))]
[(funcall rator arg*) [(funcall rator arg*)
(make-funcall (Value rator) (map Value arg*))] (make-funcall (Function rator) (map Value arg*))]
[(jmpcall label rator arg*) [(jmpcall label rator arg*)
(make-jmpcall label (Value rator) (map Value arg*))] (make-jmpcall label (Value rator) (map Value arg*))]
[(mvcall rator x) [(mvcall rator x)
@ -1153,6 +1183,39 @@
[else [else
(make-bind lhs* rhs* (make-bind lhs* rhs*
(k arg*))]))) (k arg*))])))
(define encountered-symbol-calls '())
(define (Function x)
(define (nonproc x)
(tbind ([t (Value x)])
(make-shortcut
(make-seq
(make-conditional
(tag-test t closure-mask closure-tag)
(prm 'nop)
(prm 'interrupt))
t)
(Value
(make-funcall (make-primref 'error)
(list (K 'apply) (K "~s is not a procedure") t))))))
(record-case x
[(primcall op args)
(cond
[(and (eq? op 'top-level-value)
(= (length args) 1)
(record-case (car args)
[(constant t)
(and (symbol? t) t)]
[else #f])) =>
(lambda (sym)
(unless (memq sym encountered-symbol-calls)
(set! encountered-symbol-calls
(cons sym encountered-symbol-calls)))
(prm 'mref (Value (K sym))
(K (- disp-symbol-function symbol-tag))))]
[else
(nonproc x)])]
[(primref op) (Value x)]
[else (nonproc x)]))
;;; value ;;; value
(define (Value x) (define (Value x)
(record-case x (record-case x
@ -1238,7 +1301,13 @@
(K unbound)) (K unbound))
(prm 'mset x (prm 'mset x
(K (- disp-symbol-function symbol-tag)) (K (- disp-symbol-function symbol-tag))
(K nil)) (K 0))
(prm 'mset x
(K (- disp-symbol-error-function symbol-tag))
(K 0))
(prm 'mset x
(K (- disp-symbol-unused symbol-tag))
(K 0))
x)))] x)))]
[(list) [(list)
(cond (cond
@ -1541,7 +1610,14 @@
[($fxlognot) [($fxlognot)
(Value (prm '$fxlogxor (car arg*) (K -1)))] (Value (prm '$fxlogxor (car arg*) (K -1)))]
[(+) [(+)
(let () (let ([primname
(case op
[(+) 'int+/overflow]
[else (error who "invalid op ~s" op)])]
[ID
(case op
[(+) 0]
[else (error who "invalid op ~s" op)])])
(define (handle-binary a b) (define (handle-binary a b)
(record-case a (record-case a
[(constant i) [(constant i)
@ -1553,10 +1629,10 @@
(tag-test b fixnum-mask fixnum-tag) (tag-test b fixnum-mask fixnum-tag)
(make-primcall 'nop '()) (make-primcall 'nop '())
(make-primcall 'interrupt '())) (make-primcall 'interrupt '()))
(prm 'int+/overflow (Value a) b)) (prm primname (Value a) b))
(make-funcall (Value (make-primref '+)) (make-funcall (Value (make-primref op))
(list (Value a) b)))) (list (Value a) b))))
(make-funcall (Value (make-primref '+)) (make-funcall (Value (make-primref op))
(list (Value a) b)))] (list (Value a) b)))]
[else [else
(record-case b (record-case b
@ -1569,10 +1645,10 @@
(tag-test a fixnum-mask fixnum-tag) (tag-test a fixnum-mask fixnum-tag)
(make-primcall 'nop '()) (make-primcall 'nop '())
(make-primcall 'interrupt '())) (make-primcall 'interrupt '()))
(prm 'int+/overflow a (Value b))) (prm primname a (Value b)))
(make-funcall (Value (make-primref '+)) (make-funcall (Value (make-primref op))
(list a (Value b))))) (list a (Value b)))))
(make-funcall (Value (make-primref '+)) (make-funcall (Value (make-primref op))
(list a (Value b))))] (list a (Value b))))]
[else [else
(tbind ([a (Value a)] (tbind ([a (Value a)]
@ -1583,8 +1659,8 @@
(tag-test (prm 'logor a b) fixnum-mask fixnum-tag) (tag-test (prm 'logor a b) fixnum-mask fixnum-tag)
(make-primcall 'nop '()) (make-primcall 'nop '())
(make-primcall 'interrupt '())) (make-primcall 'interrupt '()))
(prm 'int+/overflow a b)) (prm primname a b))
(make-funcall (Value (make-primref '+)) (make-funcall (Value (make-primref op))
(list a b))))])])) (list a b))))])]))
(cond (cond
[(null? arg*) (K 0)] [(null? arg*) (K 0)]
@ -1592,9 +1668,9 @@
(record-case x (record-case x
[(constant i) (not (number? i))] [(constant i) (not (number? i))]
[else #f])) arg*) [else #f])) arg*)
(make-funcall (Value (make-primref '+)) (map Value arg*))] (make-funcall (Value (make-primref op)) (map Value arg*))]
[(= (length arg*) 1) ;;; FIXME: do something better [(= (length arg*) 1) ;;; FIXME: do something better
(handle-binary (K 0) (car arg*))] (handle-binary (K ID) (car arg*))]
[(= (length arg*) 2) [(= (length arg*) 2)
(handle-binary (car arg*) (cadr arg*))] (handle-binary (car arg*) (cadr arg*))]
[else [else
@ -1604,7 +1680,7 @@
(let f ([a (car arg*)] [d (cdr arg*)]) (let f ([a (car arg*)] [d (cdr arg*)])
(cond (cond
[(null? d) a] [(null? d) a]
[else (f (prm '+ a (car d)) (cdr d))])))))]))] [else (f (prm op a (car d)) (cdr d))])))))]))]
[(-) [(-)
(let () (let ()
(define (handle-binary a b) (define (handle-binary a b)
@ -1988,7 +2064,7 @@
[(forcall op arg*) [(forcall op arg*)
(make-forcall op (map Value arg*))] (make-forcall op (map Value arg*))]
[(funcall rator arg*) [(funcall rator arg*)
(make-funcall (Value rator) (map Value arg*))] (make-funcall (Function rator) (map Value arg*))]
[(jmpcall label rator arg*) [(jmpcall label rator arg*)
(make-jmpcall label (Value rator) (map Value arg*))] (make-jmpcall label (Value rator) (map Value arg*))]
[(mvcall rator x) [(mvcall rator x)
@ -2009,12 +2085,56 @@
free*)] free*)]
[else (error who "invalid clambda ~s" x)])) [else (error who "invalid clambda ~s" x)]))
;;; ;;;
(define (error-codes)
(define (code-list symbol)
(define L1 (gensym))
(define L2 (gensym))
`(0
[movl (disp ,(- disp-symbol-value symbol-tag) (obj ,symbol)) ,cp-register]
[andl ,closure-mask ,cp-register]
[cmpl ,closure-tag ,cp-register]
[jne (label ,L1)]
[movl (disp ,(- disp-symbol-value symbol-tag) (obj ,symbol)) ,cp-register]
[movl ,cp-register (disp ,(- disp-symbol-function symbol-tag) (obj ,symbol))]
[jmp (disp ,(- disp-closure-code closure-tag) ,cp-register)]
[label ,L1]
[movl (disp ,(- disp-symbol-value symbol-tag) (obj ,symbol)) %eax]
[cmpl ,unbound %eax]
[je (label ,L2)]
[movl (obj apply) (disp -4 %esp)]
[movl (obj "~s is not a procedure") (disp -8 %esp)]
[movl %eax (disp -12 %esp)]
[movl (obj error) ,cp-register]
[movl (disp ,(- disp-symbol-system-value symbol-tag)
,cp-register) ,cp-register]
[movl ,(argc-convention 3) %eax]
[jmp (disp ,(- disp-closure-code closure-tag) ,cp-register)]
[label ,L2]
[movl (obj ,symbol) (disp -4 %esp)]
[movl (obj top-level-value) ,cp-register]
[movl (disp ,(- disp-symbol-system-value symbol-tag)
,cp-register) ,cp-register]
[movl ,(argc-convention 1) %eax]
[jmp (disp ,(- disp-closure-code closure-tag) ,cp-register)]))
(let ([ls encountered-symbol-calls])
(let ([c* (map code-list ls)])
(let ([c* (list*->code* (lambda (x) #f) c*)])
(let ([p* (map (lambda (x) ($code->closure x)) c*)])
(let f ([ls ls] [p* p*])
(cond
[(null? ls) (prm 'nop)]
[else
(make-seq
(tbind ([p (Value (K (car p*)))] [s (Value (K (car ls)))])
(Effect (prm '$init-symbol-function! s p)))
(f (cdr ls) (cdr p*)))])))))))
(define (Program x) (define (Program x)
(record-case x (record-case x
[(codes code* body) [(codes code* body)
(make-codes (let ([code* (map (lambda (x) (Clambda x Value)) code*)]
(map (lambda (x) (Clambda x Value)) code*) [body (Value body)])
(Value body))] (make-codes code*
(make-seq (error-codes) body)))]
[else (error who "invalid program ~s" x)])) [else (error who "invalid program ~s" x)]))
;;; ;;;
;(print-code x) ;(print-code x)
@ -2161,7 +2281,7 @@
(lambda (rands) (lambda (rands)
(make-set d (make-disp (car rands) (cadr rands)))))] (make-set d (make-disp (car rands) (cadr rands)))))]
[(logand logxor logor int+ int- int* [(logand logxor logor int+ int- int*
int-/overflow int+/overflow) int-/overflow int+/overflow int*/overflow)
(make-seq (make-seq
(V d (car rands)) (V d (car rands))
(S (cadr rands) (S (cadr rands)
@ -2253,6 +2373,8 @@
(handle-nontail-call (handle-nontail-call
(make-constant (make-foreign-label op)) (make-constant (make-foreign-label op))
rands #f op)] rands #f op)]
[(shortcut body handler)
(make-shortcut (E body) (E handler))]
[else (error who "invalid effect ~s" x)])) [else (error who "invalid effect ~s" x)]))
;;; impose pred ;;; impose pred
(define (P x) (define (P x)
@ -2793,7 +2915,7 @@
(values (add-var s vs) rs fs ns))] (values (add-var s vs) rs fs ns))]
[else (error who "invalid ns ~s" s)])] [else (error who "invalid ns ~s" s)])]
[else (error who "invalid d ~s" d)])] [else (error who "invalid d ~s" d)])]
[(int-/overflow int+/overflow) [(int-/overflow int+/overflow int*/overflow)
(let ([v (exception-live-set)]) (let ([v (exception-live-set)])
(unless (vector? v) (unless (vector? v)
(error who "unbound exception")) (error who "unbound exception"))
@ -3094,7 +3216,7 @@
(make-asm-instr 'move d s)]))] (make-asm-instr 'move d s)]))]
[(logand logor logxor int+ int- int* mset bset/c bset/h [(logand logor logxor int+ int- int* mset bset/c bset/h
sll sra srl sll sra srl
cltd idiv int-/overflow int+/overflow) cltd idiv int-/overflow int+/overflow int*/overflow)
(make-asm-instr op (R d) (R s))] (make-asm-instr op (R d) (R s))]
[(nop) (make-primcall 'nop '())] [(nop) (make-primcall 'nop '())]
[else (error who "invalid op ~s" op)])] [else (error who "invalid op ~s" op)])]
@ -3286,7 +3408,7 @@
[else [else
(for-each (lambda (y) (add-edge! g d y)) s) (for-each (lambda (y) (add-edge! g d y)) s)
(union (R v) s)]))] (union (R v) s)]))]
[(int-/overflow int+/overflow) [(int-/overflow int+/overflow int*/overflow)
(unless (exception-live-set) (unless (exception-live-set)
(error who "uninitialized live set")) (error who "uninitialized live set"))
(let ([s (set-rem d (set-union s (exception-live-set)))]) (let ([s (set-rem d (set-union s (exception-live-set)))])
@ -3571,7 +3693,7 @@
[(asm-instr op a b) [(asm-instr op a b)
(case op (case op
[(logor logxor logand int+ int- int* move [(logor logxor logand int+ int- int* move
int-/overflow int+/overflow) int-/overflow int+/overflow int*/overflow)
(cond (cond
[(and (eq? op 'move) (eq? a b)) [(and (eq? op 'move) (eq? a b))
(make-primcall 'nop '())] (make-primcall 'nop '())]
@ -3845,7 +3967,7 @@
LCALL LCALL
`(call %ebx) `(call %ebx)
`(addl ,(* (fxsub1 size) wordsize) ,fpr) `(addl ,(* (fxsub1 size) wordsize) ,fpr)
ac)] ac)]
[target ;;; known call [target ;;; known call
(list* `(subl ,(* (fxsub1 size) wordsize) ,fpr) (list* `(subl ,(* (fxsub1 size) wordsize) ,fpr)
`(jmp ,LCALL) `(jmp ,LCALL)
@ -3896,6 +4018,12 @@
(list* `(subl ,(R s) ,(R d)) (list* `(subl ,(R s) ,(R d))
`(jo ,L) `(jo ,L)
ac))] ac))]
[(int*/overflow)
(let ([L (or (exception-label)
(error who "no exception label"))])
(list* `(imull ,(R s) ,(R d))
`(jo ,L)
ac))]
[(int+/overflow) [(int+/overflow)
(let ([L (or (exception-label) (let ([L (or (exception-label)
(error who "no exception label"))]) (error who "no exception label"))])

View File

@ -1375,6 +1375,7 @@
(define (mk-seq e0 e1) ;;; keep e1 seq-free. (define (mk-seq e0 e1) ;;; keep e1 seq-free.
(cond (cond
[(and (primcall? e0) (eq? (primcall-op e0) 'void)) e1] [(and (primcall? e0) (eq? (primcall-op e0) 'void)) e1]
[(primref? e0) e1]
[(seq? e1) [(seq? e1)
(make-seq (make-seq e0 (seq-e0 e1)) (seq-e1 e1))] (make-seq (make-seq e0 (seq-e0 e1)) (seq-e1 e1))]
[else [else
@ -1702,57 +1703,6 @@
(Expr x)) (Expr x))
(define (insert-funcall-error-checks x)
(define who 'insert-funcall-error-checks)
(define called-symbols '())
(define (R x)
(record-case x
[(constant p)
(if (procedure? p)
x
(make-primcall '$procedure-check (list x)))]
[(primref) x]
[(clambda g cls* ?) (E x)]
[else (make-primcall '$procedure-check (list (E x)))]))
(define (E x)
(record-case x
[(constant) x]
[(var) x]
[(primref) x]
[(bind lhs* rhs* body)
(make-bind lhs* (map E rhs*) (E body))]
[(fix lhs* rhs* body)
(make-fix lhs* (map E rhs*) (E body))]
[(conditional test conseq altern)
(make-conditional (E test) (E conseq) (E altern))]
[(seq e0 e1) (make-seq (E e0) (E e1))]
[(clambda g cls* ?)
(make-clambda g
(map (lambda (cls)
(record-case cls
[(clambda-case info body)
(make-clambda-case info (E body))]))
cls*)
?)]
[(primcall op rand*)
(make-primcall op (map E rand*))]
[(forcall op rand*)
(make-forcall op (map E rand*))]
[(funcall rator rand*)
(make-funcall (R rator) (map E rand*))]
[(jmpcall label rator rand*)
(make-jmpcall label (E rator) (map E rand*))]
[(mvcall p c) (make-mvcall (E p) (E c))]
[else (error who "invalid expression ~s" (unparse x))]))
(let ([x (E x)])
(if (null? called-symbols)
x
(make-seq
(make-funcall
(make-primref 'for-each)
(list (make-primref '$reset-symbol-function!)
(make-constant called-symbols)))
x))))
(define (convert-closures prog) (define (convert-closures prog)
@ -3094,13 +3044,15 @@
(define symbol-mask 7) (define symbol-mask 7)
(define symbol-tag 2) (define symbol-tag 2)
(define disp-symbol-string 0) (define disp-symbol-string 0)
(define disp-symbol-unique-string 4) (define disp-symbol-unique-string 4)
(define disp-symbol-value 8) (define disp-symbol-value 8)
(define disp-symbol-plist 12) (define disp-symbol-plist 12)
(define disp-symbol-system-value 16) (define disp-symbol-system-value 16)
(define disp-symbol-function 20) (define disp-symbol-function 20)
(define symbol-size 24) (define disp-symbol-error-function 24)
(define disp-symbol-unused 28)
(define symbol-size 32)
(define vector-tag 5) (define vector-tag 5)
(define vector-mask 7) (define vector-mask 7)
(define disp-vector-length 0) (define disp-vector-length 0)
@ -3995,7 +3947,9 @@
(movl (int unbound) (mem disp-symbol-value apr)) (movl (int unbound) (mem disp-symbol-value apr))
(movl (int nil) (mem disp-symbol-plist apr)) (movl (int nil) (mem disp-symbol-plist apr))
(movl (int unbound) (mem disp-symbol-system-value apr)) (movl (int unbound) (mem disp-symbol-system-value apr))
(movl (int nil) (mem disp-symbol-function apr)) (movl (int 0) (mem disp-symbol-function apr))
(movl (int 0) (mem disp-symbol-error-function apr))
(movl (int 0) (mem disp-symbol-unused apr))
(movl apr eax) (movl apr eax)
(addl (int symbol-tag) eax) (addl (int symbol-tag) eax)
(addl (int (align symbol-size)) apr) (addl (int (align symbol-size)) apr)
@ -4118,7 +4072,7 @@
(list* (addl (int (fx- vector-tag disp-code-data)) eax) (list* (addl (int (fx- vector-tag disp-code-data)) eax)
ac))] ac))]
[($set-car! $set-cdr! $vector-set! $string-set! $exit [($set-car! $set-cdr! $vector-set! $string-set! $exit
$set-symbol-value! $set-symbol-function! $set-symbol-plist! $set-symbol-value! $set-symbol-plist!
$code-set! primitive-set! $code-set! primitive-set!
$set-code-object! $set-code-object+offset! $set-code-object+offset/rel! $set-code-object! $set-code-object+offset! $set-code-object+offset/rel!
$record-set! $record-set!
@ -4275,19 +4229,10 @@
(list* (movl (Simple (car arg*)) eax) (list* (movl (Simple (car arg*)) eax)
(movl (Simple (cadr arg*)) ebx) (movl (Simple (cadr arg*)) ebx)
(movl ebx (mem (fx- disp-symbol-value symbol-tag) eax)) (movl ebx (mem (fx- disp-symbol-value symbol-tag) eax))
;;; record side effect (movl (mem (fx- disp-symbol-error-function symbol-tag) eax) ebx)
(addl (int (fx- disp-symbol-value symbol-tag)) eax)
(shrl (int pageshift) eax)
(sall (int wordshift) eax)
(addl (pcb-ref 'dirty-vector) eax)
(movl (int dirty-word) (mem 0 eax))
ac)]
[($set-symbol-function!)
(list* (movl (Simple (car arg*)) eax)
(movl (Simple (cadr arg*)) ebx)
(movl ebx (mem (fx- disp-symbol-function symbol-tag) eax)) (movl ebx (mem (fx- disp-symbol-function symbol-tag) eax))
;;; record side effect ;;; record side effect
(addl (int (fx- disp-symbol-function symbol-tag)) eax) (addl (int (fx- disp-symbol-value symbol-tag)) eax)
(shrl (int pageshift) eax) (shrl (int pageshift) eax)
(sall (int wordshift) eax) (sall (int wordshift) eax)
(addl (pcb-ref 'dirty-vector) eax) (addl (pcb-ref 'dirty-vector) eax)
@ -5233,7 +5178,6 @@
[p (copy-propagate p)] [p (copy-propagate p)]
[p (rewrite-assignments p)] [p (rewrite-assignments p)]
[p (optimize-for-direct-jumps p)] [p (optimize-for-direct-jumps p)]
[p (insert-funcall-error-checks p)]
[p (convert-closures p)] [p (convert-closures p)]
[p (optimize-closures/lift-codes p)]) [p (optimize-closures/lift-codes p)])
(let ([ls* (alt-cogen p)]) (let ([ls* (alt-cogen p)])

View File

@ -340,12 +340,7 @@ reference-implementation:
(lambda (x v) (lambda (x v)
(unless (symbol? x) (unless (symbol? x)
(error 'set-top-level-value! "~s is not a symbol" x)) (error 'set-top-level-value! "~s is not a symbol" x))
($set-symbol-value! x v) ($set-symbol-value! x v)))
(if (procedure? v)
($set-symbol-function! x v)
($set-symbol-function! x
(lambda args
(error 'apply "~s is not a procedure" v))))))
(primitive-set! 'symbol? (lambda (x) (symbol? x))) (primitive-set! 'symbol? (lambda (x) (symbol? x)))

View File

@ -1,14 +1,4 @@
(primitive-set! '$reset-symbol-function!
(lambda (x)
(let ([v ($symbol-value x)])
(if (procedure? v)
($set-symbol-function! x v)
($set-symbol-function! x
(lambda args
(error 'apply "~s is not a procedure" v)))))))
(primitive-set! 'make-parameter (primitive-set! 'make-parameter
(case-lambda (case-lambda
[(x) [(x)

View File

@ -154,13 +154,7 @@
(define mem? (define mem?
(lambda (x) (lambda (x)
(and (pair? x) (and (pair? x)
;(fx= (length x) 3) (eq? (car x) 'disp))))
(eq? (car x) 'disp)
;(or (imm? (cadr x))
; (reg? (cadr x)))
;(or (imm? (caddr x))
; (reg? (caddr x)))
)))
(define small-disp? (define small-disp?
(lambda (x) (lambda (x)
@ -353,7 +347,7 @@
[(and (imm? a2) (reg? a1)) [(and (imm? a2) (reg? a1))
(CODErri c /? a1 a2 (IMM32 n ac))] (CODErri c /? a1 a2 (IMM32 n ac))]
[(and (imm? a1) (imm? a2)) [(and (imm? a1) (imm? a2))
(error 'CODEdi "unsupported2")] (error 'CODEdi "unsupported2 ~s" disp)]
[else (error 'CODEdi "unhandled ~s" disp)]))))) [else (error 'CODEdi "unhandled ~s" disp)])))))
(define (SIB s i b ac) (define (SIB s i b ac)