* optimized symbol calls using the symbol-function field.
* added error checks for applying nonprocedures.
This commit is contained in:
Abdulaziz Ghuloum
parent
87d8d5a5dd
commit
de7c43a16b
|
|
@ -3383,3 +3383,434 @@ Words allocated: 94867544
|
|||
Words reclaimed: 0
|
||||
Elapsed time...: 1846 ms (User: 1589 ms; System: 254 ms)
|
||||
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.)
|
||||
|
|
|
|||
BIN
bin/ikarus
BIN
bin/ikarus
Binary file not shown.
|
|
@ -48,13 +48,15 @@ typedef struct{
|
|||
#define meta_data 2
|
||||
#define meta_weak 3
|
||||
#define meta_pair 4
|
||||
#define meta_count 5
|
||||
#define meta_symbol 5
|
||||
#define meta_count 6
|
||||
|
||||
static int extension_amount[meta_count] = {
|
||||
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,
|
||||
data_mt,
|
||||
weak_pairs_mt,
|
||||
pointers_mt
|
||||
pointers_mt,
|
||||
symbols_mt
|
||||
};
|
||||
|
||||
|
||||
|
||||
typedef struct gc_t{
|
||||
meta_t meta[generation_count][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;
|
||||
}
|
||||
}
|
||||
|
||||
ikp mem = ik_mmap_typed(
|
||||
mapsize,
|
||||
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);
|
||||
}
|
||||
|
||||
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
|
||||
gc_alloc_new_pair(int old_gen, gc_t* gc){
|
||||
return meta_alloc(pair_size, old_gen, gc, meta_pair);
|
||||
|
|
@ -911,9 +917,6 @@ add_object_proc(gc_t* gc, ikp x)
|
|||
/* already moved */
|
||||
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)];
|
||||
int gen = t & gen_mask;
|
||||
if(gen > gc->collect_gen){
|
||||
|
|
@ -925,13 +928,16 @@ add_object_proc(gc_t* gc, ikp x)
|
|||
return y;
|
||||
}
|
||||
else if(tag == symbol_tag){
|
||||
ikp y = gc_alloc_new_ptr(symbol_size, gen, gc) + symbol_tag;
|
||||
ref(y, off_symbol_string) = ref(x, off_symbol_string);
|
||||
ref(y, off_symbol_ustring) = ref(x, off_symbol_ustring);
|
||||
ref(y, off_symbol_value) = ref(x, off_symbol_value);
|
||||
ref(y, off_symbol_plist) = ref(x, off_symbol_plist);
|
||||
//ikp y = gc_alloc_new_ptr(align(symbol_size),gen, gc) + symbol_tag;
|
||||
ikp y = gc_alloc_new_symbol(gen, gc) + symbol_tag;
|
||||
ref(y, off_symbol_string) = ref(x, off_symbol_string);
|
||||
ref(y, off_symbol_ustring) = ref(x, off_symbol_ustring);
|
||||
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_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, wordsize-symbol_tag) = y;
|
||||
#if accounting
|
||||
|
|
@ -1202,6 +1208,26 @@ collect_loop(gc_t* gc){
|
|||
} 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 */
|
||||
qupages_t* codes = gc->queues[meta_code];
|
||||
if(codes){
|
||||
|
|
@ -1240,6 +1266,23 @@ collect_loop(gc_t* gc){
|
|||
} 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++){
|
||||
meta_t* meta = &gc->meta[i][meta_ptrs];
|
||||
ikp p = meta->aq;
|
||||
|
|
@ -1289,6 +1332,15 @@ collect_loop(gc_t* gc){
|
|||
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++){
|
||||
meta_t* meta = &gc->meta[i][meta_ptrs];
|
||||
ikp p = meta->ap;
|
||||
|
|
@ -1508,6 +1560,11 @@ scan_dirty_pages(gc_t* gc){
|
|||
dirty_vec = pcb->dirty_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){
|
||||
if((t & gen_mask) > collect_gen){
|
||||
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;
|
||||
int page_gen = t & old_gen_mask;
|
||||
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);
|
||||
unsigned int d = 0;
|
||||
int j;
|
||||
|
|
|
|||
|
|
@ -113,14 +113,18 @@
|
|||
#define disp_symbol_value 8
|
||||
#define disp_symbol_plist 12
|
||||
#define disp_symbol_system_value 16
|
||||
#define disp_symbol_system_plist 20
|
||||
#define symbol_size 24
|
||||
#define disp_symbol_code 20
|
||||
#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_ustring (disp_symbol_ustring - symbol_tag)
|
||||
#define off_symbol_value (disp_symbol_value - 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_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_mask 7
|
||||
|
|
|
|||
|
|
@ -50,7 +50,9 @@ ik_make_symbol(ikp str, ikp ustr, ikpcb* pcb){
|
|||
ref(sym, off_symbol_value) = unbound_object;
|
||||
ref(sym, off_symbol_plist) = null_object;
|
||||
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;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -31,6 +31,7 @@ extern int hash_table_count;
|
|||
#define data_type 0x00000400
|
||||
#define code_type 0x00000500
|
||||
#define weak_pairs_type 0x00000600
|
||||
#define symbols_type 0x00000700
|
||||
|
||||
#define scannable_tag 0x00001000
|
||||
#define unscannable_tag 0x00000000
|
||||
|
|
@ -42,6 +43,7 @@ extern int hash_table_count;
|
|||
#define mainheap_mt (mainheap_type | unscannable_tag | retain_tag)
|
||||
#define mainstack_mt (mainstack_type | unscannable_tag | retain_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 code_mt (code_type | scannable_tag | dealloc_tag)
|
||||
#define weak_pairs_mt (weak_pairs_type | scannable_tag | dealloc_tag)
|
||||
|
|
|
|||
|
|
@ -152,6 +152,9 @@ verify_page(unsigned char* p, unsigned char* base, unsigned int* svec, unsigned
|
|||
else if(type == pointers_type){
|
||||
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){
|
||||
/* nothing to do for data */
|
||||
return p+pagesize;
|
||||
|
|
|
|||
|
|
@ -109,6 +109,42 @@
|
|||
[movl (disp -4 %esp) %eax]
|
||||
[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")
|
||||
(exit)
|
||||
|
|
|
|||
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
|
|
@ -47,6 +47,13 @@
|
|||
(for-each check-var free*)]
|
||||
[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)
|
||||
(record-case x
|
||||
[(constant) (void)]
|
||||
|
|
@ -73,7 +80,7 @@
|
|||
(Expr rator)
|
||||
(for-each Expr arg*)]
|
||||
[(jmpcall label rator arg*)
|
||||
(check-gensym label)
|
||||
(check-jmp-target label)
|
||||
(Expr rator)
|
||||
(for-each Expr arg*)]
|
||||
[(mvcall rator k)
|
||||
|
|
@ -784,6 +791,13 @@
|
|||
(prm 'sll (prm 'sra address (K pageshift)) (K wordshift)))
|
||||
(K 0)
|
||||
(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)
|
||||
(tbind ([q v])
|
||||
(tbind ([t (prm 'int+ x (K i))])
|
||||
|
|
@ -802,6 +816,19 @@
|
|||
[(primcall op arg*)
|
||||
(case op
|
||||
[(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!
|
||||
$set-symbol-unique-string! $set-symbol-plist!)
|
||||
(let ([off
|
||||
|
|
@ -852,11 +879,14 @@
|
|||
;;; card as the pair address, so no
|
||||
;;; adjustment is necessary as was the
|
||||
;;; case with vectors and records.
|
||||
(make-conditional
|
||||
(tag-test x pair-mask pair-tag)
|
||||
(make-seq
|
||||
(make-shortcut
|
||||
(seq*
|
||||
(make-conditional
|
||||
(tag-test x pair-mask pair-tag)
|
||||
(prm 'nop)
|
||||
(prm 'interrupt))
|
||||
(prm 'mset x (K off) v)
|
||||
(dirty-vector-set x))
|
||||
(smart-dirty-vector-set x (cadr arg*)))
|
||||
(Effect
|
||||
(make-funcall (make-primref 'error)
|
||||
(list (K op) (K "~s is not a pair") x)))))))]
|
||||
|
|
@ -946,7 +976,7 @@
|
|||
[(forcall op arg*)
|
||||
(make-forcall op (map Value arg*))]
|
||||
[(funcall rator arg*)
|
||||
(make-funcall (Value rator) (map Value arg*))]
|
||||
(make-funcall (Function rator) (map Value arg*))]
|
||||
[(jmpcall label rator arg*)
|
||||
(make-jmpcall label (Value rator) (map Value arg*))]
|
||||
[(mvcall rator x)
|
||||
|
|
@ -1153,6 +1183,39 @@
|
|||
[else
|
||||
(make-bind lhs* rhs*
|
||||
(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
|
||||
(define (Value x)
|
||||
(record-case x
|
||||
|
|
@ -1238,7 +1301,13 @@
|
|||
(K unbound))
|
||||
(prm 'mset x
|
||||
(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)))]
|
||||
[(list)
|
||||
(cond
|
||||
|
|
@ -1541,7 +1610,14 @@
|
|||
[($fxlognot)
|
||||
(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)
|
||||
(record-case a
|
||||
[(constant i)
|
||||
|
|
@ -1553,10 +1629,10 @@
|
|||
(tag-test b fixnum-mask fixnum-tag)
|
||||
(make-primcall 'nop '())
|
||||
(make-primcall 'interrupt '()))
|
||||
(prm 'int+/overflow (Value a) b))
|
||||
(make-funcall (Value (make-primref '+))
|
||||
(prm primname (Value a) b))
|
||||
(make-funcall (Value (make-primref op))
|
||||
(list (Value a) b))))
|
||||
(make-funcall (Value (make-primref '+))
|
||||
(make-funcall (Value (make-primref op))
|
||||
(list (Value a) b)))]
|
||||
[else
|
||||
(record-case b
|
||||
|
|
@ -1569,10 +1645,10 @@
|
|||
(tag-test a fixnum-mask fixnum-tag)
|
||||
(make-primcall 'nop '())
|
||||
(make-primcall 'interrupt '()))
|
||||
(prm 'int+/overflow a (Value b)))
|
||||
(make-funcall (Value (make-primref '+))
|
||||
(prm primname a (Value b)))
|
||||
(make-funcall (Value (make-primref op))
|
||||
(list a (Value b)))))
|
||||
(make-funcall (Value (make-primref '+))
|
||||
(make-funcall (Value (make-primref op))
|
||||
(list a (Value b))))]
|
||||
[else
|
||||
(tbind ([a (Value a)]
|
||||
|
|
@ -1583,8 +1659,8 @@
|
|||
(tag-test (prm 'logor a b) fixnum-mask fixnum-tag)
|
||||
(make-primcall 'nop '())
|
||||
(make-primcall 'interrupt '()))
|
||||
(prm 'int+/overflow a b))
|
||||
(make-funcall (Value (make-primref '+))
|
||||
(prm primname a b))
|
||||
(make-funcall (Value (make-primref op))
|
||||
(list a b))))])]))
|
||||
(cond
|
||||
[(null? arg*) (K 0)]
|
||||
|
|
@ -1592,9 +1668,9 @@
|
|||
(record-case x
|
||||
[(constant i) (not (number? i))]
|
||||
[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
|
||||
(handle-binary (K 0) (car arg*))]
|
||||
(handle-binary (K ID) (car arg*))]
|
||||
[(= (length arg*) 2)
|
||||
(handle-binary (car arg*) (cadr arg*))]
|
||||
[else
|
||||
|
|
@ -1604,7 +1680,7 @@
|
|||
(let f ([a (car arg*)] [d (cdr arg*)])
|
||||
(cond
|
||||
[(null? d) a]
|
||||
[else (f (prm '+ a (car d)) (cdr d))])))))]))]
|
||||
[else (f (prm op a (car d)) (cdr d))])))))]))]
|
||||
[(-)
|
||||
(let ()
|
||||
(define (handle-binary a b)
|
||||
|
|
@ -1988,7 +2064,7 @@
|
|||
[(forcall op arg*)
|
||||
(make-forcall op (map Value arg*))]
|
||||
[(funcall rator arg*)
|
||||
(make-funcall (Value rator) (map Value arg*))]
|
||||
(make-funcall (Function rator) (map Value arg*))]
|
||||
[(jmpcall label rator arg*)
|
||||
(make-jmpcall label (Value rator) (map Value arg*))]
|
||||
[(mvcall rator x)
|
||||
|
|
@ -2009,12 +2085,56 @@
|
|||
free*)]
|
||||
[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)
|
||||
(record-case x
|
||||
[(codes code* body)
|
||||
(make-codes
|
||||
(map (lambda (x) (Clambda x Value)) code*)
|
||||
(Value body))]
|
||||
(let ([code* (map (lambda (x) (Clambda x Value)) code*)]
|
||||
[body (Value body)])
|
||||
(make-codes code*
|
||||
(make-seq (error-codes) body)))]
|
||||
[else (error who "invalid program ~s" x)]))
|
||||
;;;
|
||||
;(print-code x)
|
||||
|
|
@ -2161,7 +2281,7 @@
|
|||
(lambda (rands)
|
||||
(make-set d (make-disp (car rands) (cadr rands)))))]
|
||||
[(logand logxor logor int+ int- int*
|
||||
int-/overflow int+/overflow)
|
||||
int-/overflow int+/overflow int*/overflow)
|
||||
(make-seq
|
||||
(V d (car rands))
|
||||
(S (cadr rands)
|
||||
|
|
@ -2253,6 +2373,8 @@
|
|||
(handle-nontail-call
|
||||
(make-constant (make-foreign-label op))
|
||||
rands #f op)]
|
||||
[(shortcut body handler)
|
||||
(make-shortcut (E body) (E handler))]
|
||||
[else (error who "invalid effect ~s" x)]))
|
||||
;;; impose pred
|
||||
(define (P x)
|
||||
|
|
@ -2793,7 +2915,7 @@
|
|||
(values (add-var s vs) rs fs ns))]
|
||||
[else (error who "invalid ns ~s" s)])]
|
||||
[else (error who "invalid d ~s" d)])]
|
||||
[(int-/overflow int+/overflow)
|
||||
[(int-/overflow int+/overflow int*/overflow)
|
||||
(let ([v (exception-live-set)])
|
||||
(unless (vector? v)
|
||||
(error who "unbound exception"))
|
||||
|
|
@ -3094,7 +3216,7 @@
|
|||
(make-asm-instr 'move d s)]))]
|
||||
[(logand logor logxor int+ int- int* mset bset/c bset/h
|
||||
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))]
|
||||
[(nop) (make-primcall 'nop '())]
|
||||
[else (error who "invalid op ~s" op)])]
|
||||
|
|
@ -3286,7 +3408,7 @@
|
|||
[else
|
||||
(for-each (lambda (y) (add-edge! g d y)) s)
|
||||
(union (R v) s)]))]
|
||||
[(int-/overflow int+/overflow)
|
||||
[(int-/overflow int+/overflow int*/overflow)
|
||||
(unless (exception-live-set)
|
||||
(error who "uninitialized live set"))
|
||||
(let ([s (set-rem d (set-union s (exception-live-set)))])
|
||||
|
|
@ -3571,7 +3693,7 @@
|
|||
[(asm-instr op a b)
|
||||
(case op
|
||||
[(logor logxor logand int+ int- int* move
|
||||
int-/overflow int+/overflow)
|
||||
int-/overflow int+/overflow int*/overflow)
|
||||
(cond
|
||||
[(and (eq? op 'move) (eq? a b))
|
||||
(make-primcall 'nop '())]
|
||||
|
|
@ -3896,6 +4018,12 @@
|
|||
(list* `(subl ,(R s) ,(R d))
|
||||
`(jo ,L)
|
||||
ac))]
|
||||
[(int*/overflow)
|
||||
(let ([L (or (exception-label)
|
||||
(error who "no exception label"))])
|
||||
(list* `(imull ,(R s) ,(R d))
|
||||
`(jo ,L)
|
||||
ac))]
|
||||
[(int+/overflow)
|
||||
(let ([L (or (exception-label)
|
||||
(error who "no exception label"))])
|
||||
|
|
|
|||
|
|
@ -1375,6 +1375,7 @@
|
|||
(define (mk-seq e0 e1) ;;; keep e1 seq-free.
|
||||
(cond
|
||||
[(and (primcall? e0) (eq? (primcall-op e0) 'void)) e1]
|
||||
[(primref? e0) e1]
|
||||
[(seq? e1)
|
||||
(make-seq (make-seq e0 (seq-e0 e1)) (seq-e1 e1))]
|
||||
[else
|
||||
|
|
@ -1702,57 +1703,6 @@
|
|||
(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)
|
||||
|
|
@ -3094,13 +3044,15 @@
|
|||
|
||||
(define symbol-mask 7)
|
||||
(define symbol-tag 2)
|
||||
(define disp-symbol-string 0)
|
||||
(define disp-symbol-unique-string 4)
|
||||
(define disp-symbol-value 8)
|
||||
(define disp-symbol-plist 12)
|
||||
(define disp-symbol-system-value 16)
|
||||
(define disp-symbol-function 20)
|
||||
(define symbol-size 24)
|
||||
(define disp-symbol-string 0)
|
||||
(define disp-symbol-unique-string 4)
|
||||
(define disp-symbol-value 8)
|
||||
(define disp-symbol-plist 12)
|
||||
(define disp-symbol-system-value 16)
|
||||
(define disp-symbol-function 20)
|
||||
(define disp-symbol-error-function 24)
|
||||
(define disp-symbol-unused 28)
|
||||
(define symbol-size 32)
|
||||
(define vector-tag 5)
|
||||
(define vector-mask 7)
|
||||
(define disp-vector-length 0)
|
||||
|
|
@ -3995,7 +3947,9 @@
|
|||
(movl (int unbound) (mem disp-symbol-value apr))
|
||||
(movl (int nil) (mem disp-symbol-plist 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)
|
||||
(addl (int symbol-tag) eax)
|
||||
(addl (int (align symbol-size)) apr)
|
||||
|
|
@ -4118,7 +4072,7 @@
|
|||
(list* (addl (int (fx- vector-tag disp-code-data)) eax)
|
||||
ac))]
|
||||
[($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!
|
||||
$set-code-object! $set-code-object+offset! $set-code-object+offset/rel!
|
||||
$record-set!
|
||||
|
|
@ -4275,19 +4229,10 @@
|
|||
(list* (movl (Simple (car arg*)) eax)
|
||||
(movl (Simple (cadr arg*)) ebx)
|
||||
(movl ebx (mem (fx- disp-symbol-value symbol-tag) eax))
|
||||
;;; record side effect
|
||||
(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 (mem (fx- disp-symbol-error-function symbol-tag) eax) ebx)
|
||||
(movl ebx (mem (fx- disp-symbol-function symbol-tag) eax))
|
||||
;;; 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)
|
||||
(sall (int wordshift) eax)
|
||||
(addl (pcb-ref 'dirty-vector) eax)
|
||||
|
|
@ -5233,7 +5178,6 @@
|
|||
[p (copy-propagate p)]
|
||||
[p (rewrite-assignments p)]
|
||||
[p (optimize-for-direct-jumps p)]
|
||||
[p (insert-funcall-error-checks p)]
|
||||
[p (convert-closures p)]
|
||||
[p (optimize-closures/lift-codes p)])
|
||||
(let ([ls* (alt-cogen p)])
|
||||
|
|
|
|||
|
|
@ -340,12 +340,7 @@ reference-implementation:
|
|||
(lambda (x v)
|
||||
(unless (symbol? x)
|
||||
(error 'set-top-level-value! "~s is not a symbol" x))
|
||||
($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))))))
|
||||
($set-symbol-value! x v)))
|
||||
|
||||
(primitive-set! 'symbol? (lambda (x) (symbol? x)))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
(case-lambda
|
||||
[(x)
|
||||
|
|
|
|||
|
|
@ -154,13 +154,7 @@
|
|||
(define mem?
|
||||
(lambda (x)
|
||||
(and (pair? x)
|
||||
;(fx= (length x) 3)
|
||||
(eq? (car x) 'disp)
|
||||
;(or (imm? (cadr x))
|
||||
; (reg? (cadr x)))
|
||||
;(or (imm? (caddr x))
|
||||
; (reg? (caddr x)))
|
||||
)))
|
||||
(eq? (car x) 'disp))))
|
||||
|
||||
(define small-disp?
|
||||
(lambda (x)
|
||||
|
|
@ -353,7 +347,7 @@
|
|||
[(and (imm? a2) (reg? a1))
|
||||
(CODErri c /? a1 a2 (IMM32 n ac))]
|
||||
[(and (imm? a1) (imm? a2))
|
||||
(error 'CODEdi "unsupported2")]
|
||||
(error 'CODEdi "unsupported2 ~s" disp)]
|
||||
[else (error 'CODEdi "unhandled ~s" disp)])))))
|
||||
|
||||
(define (SIB s i b ac)
|
||||
|
|
|
|||
Loading…
Reference in New Issue