diff --git a/benchmarks/results.Larceny-r6rs b/benchmarks/results.Larceny-r6rs index cdba640..247cb17 100644 --- a/benchmarks/results.Larceny-r6rs +++ b/benchmarks/results.Larceny-r6rs @@ -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.) diff --git a/bin/ikarus b/bin/ikarus index cb116cb..95839fe 100755 Binary files a/bin/ikarus and b/bin/ikarus differ diff --git a/bin/ikarus-collect.c b/bin/ikarus-collect.c index 7dc20bf..449792f 100644 --- a/bin/ikarus-collect.c +++ b/bin/ikarus-collect.c @@ -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; diff --git a/bin/ikarus-data.h b/bin/ikarus-data.h index d1dfb3c..cf90392 100644 --- a/bin/ikarus-data.h +++ b/bin/ikarus-data.h @@ -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 diff --git a/bin/ikarus-symbol-table.c b/bin/ikarus-symbol-table.c index ad34bb6..f04ed45 100644 --- a/bin/ikarus-symbol-table.c +++ b/bin/ikarus-symbol-table.c @@ -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; } diff --git a/bin/ikarus.h b/bin/ikarus.h index ddc928d..6cb0a18 100644 --- a/bin/ikarus.h +++ b/bin/ikarus.h @@ -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) diff --git a/bin/verify-integrity.c b/bin/verify-integrity.c index c9ab96d..32669a1 100644 --- a/bin/verify-integrity.c +++ b/bin/verify-integrity.c @@ -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; diff --git a/src/asm-tests.ss b/src/asm-tests.ss index e056ce8..7efb76a 100755 --- a/src/asm-tests.ss +++ b/src/asm-tests.ss @@ -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) diff --git a/src/ikarus.boot b/src/ikarus.boot index 9269fcc..57a4ab8 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/libaltcogen.ss b/src/libaltcogen.ss index 5b16245..cb9fda7 100644 --- a/src/libaltcogen.ss +++ b/src/libaltcogen.ss @@ -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 '())] @@ -3845,7 +3967,7 @@ LCALL `(call %ebx) `(addl ,(* (fxsub1 size) wordsize) ,fpr) - ac)] + ac)] [target ;;; known call (list* `(subl ,(* (fxsub1 size) wordsize) ,fpr) `(jmp ,LCALL) @@ -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"))]) diff --git a/src/libcompile.ss b/src/libcompile.ss index 3d00a5b..1c1e685 100644 --- a/src/libcompile.ss +++ b/src/libcompile.ss @@ -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)]) diff --git a/src/libcore.ss b/src/libcore.ss index 1f3cd39..54c452c 100644 --- a/src/libcore.ss +++ b/src/libcore.ss @@ -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))) diff --git a/src/libhandlers.ss b/src/libhandlers.ss index d19748c..801455e 100644 --- a/src/libhandlers.ss +++ b/src/libhandlers.ss @@ -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) diff --git a/src/libintelasm.ss b/src/libintelasm.ss index a582a75..2660fdf 100644 --- a/src/libintelasm.ss +++ b/src/libintelasm.ss @@ -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)