diff --git a/benchmarks/results.Larceny-r6rs b/benchmarks/results.Larceny-r6rs index 060e86a..e23fc83 100644 --- a/benchmarks/results.Larceny-r6rs +++ b/benchmarks/results.Larceny-r6rs @@ -4065,3 +4065,1107 @@ Words allocated: 100923902 Words reclaimed: 0 Elapsed time...: 6579 ms (User: 6509 ms; System: 70 ms) Elapsed GC time: 282 ms (CPU: 298 in 385 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 16:04:02 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...: 6584 ms (User: 6511 ms; System: 72 ms) +Elapsed GC time: 302 ms (CPU: 297 in 385 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 16:04:14 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...: 6584 ms (User: 6510 ms; System: 72 ms) +Elapsed GC time: 276 ms (CPU: 280 in 385 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 16:06: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 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...: 1856 ms (User: 1589 ms; System: 256 ms) +Elapsed GC time: 1161 ms (CPU: 1135 in 360 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 16:31:57 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 gcold 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) + + +> 25 megabytes +0 work units per step. +promotion ratio is 1:10 +pointer mutation rate is 10 +10000 steps +Allocating 76 trees. + (24902160 bytes) + (1245108 nodes) +Initialization complete... + +Words allocated: 2754230651 +Words reclaimed: 0 +Elapsed time...: 24989 ms (User: 20824 ms; System: 4156 ms) +Elapsed GC time: 13472 ms (CPU: 13464 in 10508 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 18:16: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 gcold 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) + + +> 25 megabytes +0 work units per step. +promotion ratio is 1:10 +pointer mutation rate is 10 +10000 steps +Allocating 76 trees. + (24902160 bytes) + (1245108 nodes) +Initialization complete... + +Words allocated: 2754230651 +Words reclaimed: 0 +Elapsed time...: 24942 ms (User: 20798 ms; System: 4135 ms) +Elapsed GC time: 13398 ms (CPU: 13451 in 10508 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 18:29:54 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...: 4303 ms (User: 3761 ms; System: 540 ms) +Elapsed GC time: 2469 ms (CPU: 2470 in 768 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 18:30: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 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...: 1261 ms (User: 1254 ms; System: 7 ms) +Elapsed GC time: 56 ms (CPU: 58 in 131 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 18:31: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 dynamic 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: 14942078 +Words reclaimed: 0 +Elapsed time...: 776 ms (User: 713 ms; System: 63 ms) +Elapsed GC time: 194 ms (CPU: 189 in 57 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 18:32:05 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 sboyer 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: 16514958 +Words reclaimed: 0 +Elapsed time...: 1319 ms (User: 1309 ms; System: 8 ms) +Elapsed GC time: 38 ms (CPU: 44 in 63 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 18:32: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 nboyer 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: 50855620 +Words reclaimed: 0 +Elapsed time...: 1691 ms (User: 1604 ms; System: 86 ms) +Elapsed GC time: 431 ms (CPU: 432 in 194 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 18:33:40 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 matrix 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: 87555006 +Words reclaimed: 0 +Elapsed time...: 1862 ms (User: 1851 ms; System: 10 ms) +Elapsed GC time: 136 ms (CPU: 127 in 334 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 18:34: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 maze 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: 36170288 +Words reclaimed: 0 +Elapsed time...: 5834 ms (User: 5799 ms; System: 32 ms) +Elapsed GC time: 86 ms (CPU: 82 in 138 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 18:34: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 browse 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: 120585534 +Words reclaimed: 0 +Elapsed time...: 2860 ms (User: 2850 ms; System: 10 ms) +Elapsed GC time: 170 ms (CPU: 171 in 460 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 18:35:23 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 earley 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: 123206268 +Words reclaimed: 0 +Elapsed time...: 2030 ms (User: 1934 ms; System: 94 ms) +Elapsed GC time: 574 ms (CPU: 574 in 470 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 18:35:47 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...: 1263 ms (User: 1255 ms; System: 8 ms) +Elapsed GC time: 60 ms (CPU: 55 in 131 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 18:36:08 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 graphs 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: 157021446 +Words reclaimed: 0 +Elapsed time...: 1648 ms (User: 1626 ms; System: 22 ms) +Elapsed GC time: 266 ms (CPU: 269 in 599 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 18:36:31 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 boyer 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: 9174986 +Words reclaimed: 0 +Elapsed time...: 604 ms (User: 589 ms; System: 15 ms) +Elapsed GC time: 82 ms (CPU: 84 in 35 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 18:41: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 conform 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: 22544148 +Words reclaimed: 0 +Elapsed time...: 1444 ms (User: 1432 ms; System: 10 ms) +Elapsed GC time: 66 ms (CPU: 64 in 86 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 18:41: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 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...: 1682 ms (User: 1678 ms; System: 4 ms) +Elapsed GC time: 33 ms (CPU: 31 in 74 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 18:41:51 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 mazefun 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: 47447672 +Words reclaimed: 0 +Elapsed time...: 1295 ms (User: 1286 ms; System: 9 ms) +Elapsed GC time: 69 ms (CPU: 79 in 181 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 18:42: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 browse 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: 120585534 +Words reclaimed: 0 +Elapsed time...: 2861 ms (User: 2850 ms; System: 10 ms) +Elapsed GC time: 173 ms (CPU: 172 in 460 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 18:42:34 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...: 1854 ms (User: 1588 ms; System: 257 ms) +Elapsed GC time: 1134 ms (CPU: 1144 in 360 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 18:43: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 simplex 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) + + +> + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 18:44: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 simplex 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) + + +> + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 18:45:19 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...: 4302 ms (User: 3759 ms; System: 541 ms) +Elapsed GC time: 2462 ms (CPU: 2452 in 768 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 18:46:48 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 pi 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) + + +> + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 19:20: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 pi 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) + + +> + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 19:28:20 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 trav2 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...: 1249 ms (User: 1247 ms; System: 2 ms) +Elapsed GC time: 0 ms (CPU: 0 in 0 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 19:28:36 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 trav1 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: 12320426 +Words reclaimed: 0 +Elapsed time...: 1248 ms (User: 1208 ms; System: 39 ms) +Elapsed GC time: 192 ms (CPU: 189 in 47 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 19:30: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 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...: 1953 ms (User: 1808 ms; System: 146 ms) +Elapsed GC time: 2 ms (CPU: 5 in 31 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 19:30:55 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 perm9 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: 27000532 +Words reclaimed: 0 +Elapsed time...: 1550 ms (User: 1332 ms; System: 216 ms) +Elapsed GC time: 1016 ms (CPU: 1011 in 103 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 19:41: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 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...: 1905 ms (User: 1894 ms; System: 11 ms) +Elapsed GC time: 250 ms (CPU: 332 in 931 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 19:42:09 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 fft 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: 217579520 +Words reclaimed: 0 +Elapsed time...: 1653 ms (User: 1622 ms; System: 29 ms) +Elapsed GC time: 298 ms (CPU: 503 in 830 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 19:42:54 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: 60 ms (CPU: 62 in 165 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 19:43:47 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 triangl 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: 262144 +Words reclaimed: 0 +Elapsed time...: 2105 ms (User: 2102 ms; System: 2 ms) +Elapsed GC time: 1 ms (CPU: 1 in 1 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 19:51: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 mbrot 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: 551809449 +Words reclaimed: 0 +Elapsed time...: 2237 ms (User: 2221 ms; System: 15 ms) +Elapsed GC time: 756 ms (CPU: 762 in 2105 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 19:53:11 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 pnpoly 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: 72351712 +Words reclaimed: 0 +Elapsed time...: 1454 ms (User: 1449 ms; System: 4 ms) +Elapsed GC time: 92 ms (CPU: 99 in 276 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 19:54:57 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 pnpoly 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: 72351712 +Words reclaimed: 0 +Elapsed time...: 1454 ms (User: 1450 ms; System: 4 ms) +Elapsed GC time: 98 ms (CPU: 91 in 276 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 19:55:06 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 pnpoly 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: 72351712 +Words reclaimed: 0 +Elapsed time...: 1457 ms (User: 1450 ms; System: 5 ms) +Elapsed GC time: 100 ms (CPU: 93 in 276 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 19:55:36 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 pnpoly 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: 72351712 +Words reclaimed: 0 +Elapsed time...: 1455 ms (User: 1450 ms; System: 4 ms) +Elapsed GC time: 99 ms (CPU: 95 in 276 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 20:02:20 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 deriv 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: 244055778 +Words reclaimed: 0 +Elapsed time...: 1477 ms (User: 1465 ms; System: 10 ms) +Elapsed GC time: 339 ms (CPU: 339 in 931 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 20:02:39 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 wc 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...: 294 ms (User: 249 ms; System: 44 ms) +Elapsed GC time: 0 ms (CPU: 0 in 0 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 20:03:06 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 nqueens 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: 71302772 +Words reclaimed: 0 +Elapsed time...: 1596 ms (User: 1584 ms; System: 11 ms) +Elapsed GC time: 94 ms (CPU: 100 in 272 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 20:04:14 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 primes 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: 92273280 +Words reclaimed: 0 +Elapsed time...: 7601 ms (User: 7567 ms; System: 31 ms) +Elapsed GC time: 126 ms (CPU: 123 in 352 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 20:06: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 primes 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: 92273280 +Words reclaimed: 0 +Elapsed time...: 7601 ms (User: 7568 ms; System: 31 ms) +Elapsed GC time: 125 ms (CPU: 128 in 352 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 20:13: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 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...: 1781 ms (User: 1779 ms; System: 1 ms) +Elapsed GC time: 0 ms (CPU: 0 in 0 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 20:13: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 ack 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...: 85 ms (User: 84 ms; System: 0 ms) +Elapsed GC time: 0 ms (CPU: 0 in 0 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 20:14: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 ack 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...: 836 ms (User: 834 ms; System: 1 ms) +Elapsed GC time: 0 ms (CPU: 0 in 0 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 20:15: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 sum 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...: 554 ms (User: 553 ms; System: 1 ms) +Elapsed GC time: 0 ms (CPU: 0 in 0 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 20:15:53 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 sum 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...: 554 ms (User: 553 ms; System: 1 ms) +Elapsed GC time: 0 ms (CPU: 0 in 0 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 20:17: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 tail 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: 19136354 +Words reclaimed: 0 +Elapsed time...: 706 ms (User: 575 ms; System: 130 ms) +Elapsed GC time: 43 ms (CPU: 45 in 73 collections.) + +**************************** +Benchmarking Larceny-r6rs on Sat Mar 3 20:29: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 sum 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...: 554 ms (User: 553 ms; System: 1 ms) +Elapsed GC time: 0 ms (CPU: 0 in 0 collections.) diff --git a/benchmarks/src/gcold.scm b/benchmarks/src/gcold.scm index 7d01ac7..2dc3cc7 100644 --- a/benchmarks/src/gcold.scm +++ b/benchmarks/src/gcold.scm @@ -303,7 +303,7 @@ (define (oldGenMut n) (do ((i 0 (+ i 1))) ((>= i (quotient n 2))) - (oldGenSwapSubTrees))) + (oldGenSwapSubtrees))) ; Does the amount of mutator work appropriate for n bytes of young-gen ; garbage allocation. diff --git a/benchmarks/src/simplex.scm b/benchmarks/src/simplex.scm index a8811e4..d165310 100644 --- a/benchmarks/src/simplex.scm +++ b/benchmarks/src/simplex.scm @@ -10,6 +10,7 @@ (define (simplex a m1 m2 m3) (define *epsilon* 1e-6) + ;(define *epsilon* 0.000001) (if (not (and (>= m1 0) (>= m2 0) (>= m3 0) diff --git a/benchmarks/src/smlboyer.scm b/benchmarks/src/smlboyer.scm index 55e0fa9..10cffdf 100644 --- a/benchmarks/src/smlboyer.scm +++ b/benchmarks/src/smlboyer.scm @@ -199,8 +199,8 @@ (define (CProp.terms x) (cadr x)) (define (cterm_to_term x) - (if (Cvar? x) - (Var (Cvar.i x)) + (if (CVar? x) + (Var (CVar.i x)) (Prop (get (CProp.name x)) (map cterm_to_term (CProp.terms x))))) diff --git a/bin/ikarus b/bin/ikarus index 95839fe..f029526 100755 Binary files a/bin/ikarus and b/bin/ikarus differ diff --git a/bin/ikarus-numerics.c b/bin/ikarus-numerics.c index bf8123a..16079b5 100644 --- a/bin/ikarus-numerics.c +++ b/bin/ikarus-numerics.c @@ -708,12 +708,12 @@ ikrt_bnbnminus(ikp x, ikp y, ikpcb* pcb){ ref(x, -vector_tag+disp_bignum_data+(xlimbs-1)*wordsize))){ s1 = y; n1 = ylimbs; s2 = x; n2 = xlimbs; - result_sign = (1 << bignum_length_shift) - ysign; + result_sign = (1 << bignum_sign_shift) - ysign; } } else { s1 = y; n1 = ylimbs; s2 = x; n2 = xlimbs; - result_sign = (1 << bignum_length_shift) - ysign; + result_sign = (1 << bignum_sign_shift) - ysign; } } /* |s1| > |s2| */ diff --git a/src/ikarus.boot b/src/ikarus.boot index d6d0883..e3b1b1c 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/libaltcogen.ss b/src/libaltcogen.ss index aea4970..961b8fc 100644 --- a/src/libaltcogen.ss +++ b/src/libaltcogen.ss @@ -176,6 +176,7 @@ [$char<= p] [$char> p] [$char>= p] + [$char->fixnum vt] [$fixnum->char vt] @@ -327,7 +328,7 @@ (record-case op [(primref name) (cond - [(must-open-code? name) + [(primop? name) (make-primcall name arg*)] [(open-codeable? name) (error 'chaitin-compiler "primitive ~s is not supported" @@ -779,1552 +780,6 @@ (include "pass-specify-rep.ss") -#;(define (specify-representation x) - (define who 'specify-representation) - ;;; - (define fixnum-scale 4) - (define fixnum-shift 2) - (define fixnum-tag 0) - (define fixnum-mask 3) - (define pcb-dirty-vector-offset 28) - ;;; - (define nop (make-primcall 'nop '())) - ;;; - (import primops) - (define (handle-fix lhs* rhs* body) - (define (closure-size x) - (record-case x - [(closure code free*) - (if (null? free*) - 0 - (align (+ disp-closure-data - (* (length free*) wordsize))))])) - (define (partition p? lhs* rhs*) - (cond - [(null? lhs*) (values '() '() '() '())] - [else - (let-values ([(a* b* c* d*) - (partition p? (cdr lhs*) (cdr rhs*))] - [(x y) (values (car lhs*) (car rhs*))]) - (cond - [(p? x y) - (values (cons x a*) (cons y b*) c* d*)] - [else - (values a* b* (cons x c*) (cons y d*))]))])) - (define (combinator? lhs rhs) - (record-case rhs - [(closure code free*) (null? free*)])) - (define (sum n* n) - (cond - [(null? n*) n] - [else (sum (cdr n*) (+ n (car n*)))])) - (define (adders lhs n n*) - (cond - [(null? n*) '()] - [else - (cons (prm 'int+ lhs (K n)) - (adders lhs (+ n (car n*)) (cdr n*)))])) - (define (build-closures lhs* rhs* body) - (let ([lhs (car lhs*)] [rhs (car rhs*)] - [lhs* (cdr lhs*)] [rhs* (cdr rhs*)]) - (let ([n (closure-size rhs)] - [n* (map closure-size rhs*)]) - (make-bind (list lhs) - (list (prm 'alloc - (K (sum n* n)) - (K closure-tag))) - (make-bind lhs* (adders lhs n n*) - body))))) - (define (build-setters lhs* rhs* body) - (define (build-setter lhs rhs body) - (record-case rhs - [(closure code free*) - (make-seq - (prm 'mset lhs - (K (- disp-closure-code closure-tag)) - (Value code)) - (let f ([ls free*] - [i (- disp-closure-data closure-tag)]) - (cond - [(null? ls) body] - [else - (make-seq - (prm 'mset lhs (K i) (Value (car ls))) - (f (cdr ls) (+ i wordsize)))])))])) - (cond - [(null? lhs*) body] - [else - (build-setter (car lhs*) (car rhs*) - (build-setters (cdr lhs*) (cdr rhs*) body))])) - (let-values ([(flhs* frhs* clhs* crhs*) - (partition combinator? lhs* rhs*)]) - (cond - [(null? clhs*) (make-bind flhs* (map Value frhs*) body)] - [(null? flhs*) - (build-closures clhs* crhs* - (build-setters clhs* crhs* body))] - [else - (make-bind flhs* (map Value frhs*) - (build-closures clhs* crhs* - (build-setters clhs* crhs* body)))]))) - ;;; - (define (constant-rep x) - (let ([c (constant-value x)]) - (cond - [(fixnum? c) (make-constant (* c fixnum-scale))] - [(boolean? c) (make-constant (if c bool-t bool-f))] - [(eq? c (void)) (make-constant void-object)] - [(bwp-object? c) (make-constant bwp-object)] - [(char? c) (make-constant - (fxlogor char-tag - (fxsll (char->integer c) char-shift)))] - [(null? c) (make-constant nil)] - [else (make-constant (make-object c))]))) - ;;; - (define (K x) (make-constant x)) - (define (prm op . rands) (make-primcall op rands)) - (define-syntax tbind - (lambda (x) - (syntax-case x () - [(_ ([lhs* rhs*] ...) b b* ...) - #'(let ([ls (list rhs* ...)]) - (let ([lhs* (unique-var 'lhs*)] ...) - (make-bind (list lhs* ...) ls - (begin b b* ...))))]))) - (define (Effect x) - (define (dirty-vector-set address) - (prm 'mset - (prm 'int+ - (prm 'mref pcr (K 28)) ;;; FIXME: make srl - (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))]) - (make-seq - (prm 'mset t (K 0) q) - (dirty-vector-set t))))) - (define (smart-mem-assign what v x i) - (record-case what - [(constant t) - (if (or (fixnum? t) (immediate? t)) - (prm 'mset x (K i) v) - (mem-assign v x i))] - [else (mem-assign v x i)])) - (record-case x - [(bind lhs* rhs* body) - (make-bind lhs* (map Value rhs*) (Effect body))] - [(conditional e0 e1 e2) - (make-conditional (Pred e0) (Effect e1) (Effect e2))] - [(seq e0 e1) - (make-seq (Effect e0) (Effect e1))] - [(fix lhs* rhs* body) - (handle-fix lhs* rhs* (Effect body))] - [(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 - (case op - [(primitive-set!) disp-symbol-system-value] - [($set-symbol-value!) disp-symbol-value] - [($set-symbol-string!) disp-symbol-string] - [($set-symbol-unique-string!) disp-symbol-unique-string] - [($set-symbol-plist!) disp-symbol-plist] - [else (err x)])]) - (tbind ([x (Value (car arg*))] [v (Value (cadr arg*))]) - (mem-assign v x (- off symbol-tag))))] - [($vector-set! $record-set!) - (tbind ([x (Value (car arg*))] - [v (Value (caddr arg*))]) - (let ([i (cadr arg*)]) - (record-case i - [(constant i) - (unless (fixnum? i) - (error who "invalid arg ~s to ~s" i op)) - (mem-assign v x - (+ (* i wordsize) - (- disp-vector-data vector-tag)))] - [else - (tbind ([i (Value i)]) - (mem-assign v - (prm 'int+ x i) - (- disp-vector-data vector-tag)))])))] - [(vector-set!) - (tbind ([a0 (Value (car arg*))] - [val (Value (caddr arg*))]) - (let ([a1 (cadr arg*)]) - (record-case a1 - [(constant i) - (if (and (fixnum? i) (fx>= i 0)) - (make-shortcut - (seq* - (make-conditional - (tag-test a0 vector-mask vector-tag) - (prm 'nop) - (prm 'interrupt)) - (tbind ([t (prm 'mref a0 - (K (- disp-vector-length vector-tag)))]) - (seq* - (make-conditional - (prm '< (K (* i fixnum-scale)) t) - (prm 'nop) - (prm 'interrupt)) - (make-conditional - (tag-test t fixnum-mask fixnum-tag) - (prm 'nop) - (prm 'interrupt)) - (smart-mem-assign (caddr arg*) val a0 - (+ (* i wordsize) - (- disp-vector-data vector-tag)))))) - (Effect - (make-funcall (make-primref 'vector-set!) - (list a0 (Value a1) val)))) - (Effect - (make-funcall (make-primref 'vector-set!) - (list a0 (Value a1) val))))] - [else - (tbind ([a1 (Value a1)]) - (make-shortcut - (seq* - (make-conditional - (tag-test a0 vector-mask vector-tag) - (prm 'nop) - (prm 'interrupt)) - (tbind ([t (prm 'mref a0 - (K (- disp-vector-length vector-tag)))]) - (seq* - (make-conditional - (prm 'u< a1 t) - (prm 'nop) - (prm 'interrupt)) - (make-conditional - (tag-test (prm 'logor t a1) fixnum-mask fixnum-tag) - (prm 'nop) - (prm 'interrupt)) - (mem-assign val - (prm 'int+ a0 a1) - (- disp-vector-data vector-tag))))) - (Effect - (make-funcall (make-primref 'vector-set!) - (list a0 a1 val)))))])))] - [($set-car! $set-cdr!) - (let ([off (if (eq? op '$set-car!) - (- disp-car pair-tag) - (- disp-cdr pair-tag))]) - (tbind ([x (Value (car arg*))] - [v (Value (cadr arg*))]) - (seq* ;;; car/cdr addresses are in the same - ;;; card as the pair address, so no - ;;; adjustment is necessary as was the - ;;; case with vectors and records. - (prm 'mset x (K off) v) - (dirty-vector-set x))))] - [(set-car! set-cdr!) - (let ([off (if (eq? op 'set-car!) - (- disp-car pair-tag) - (- disp-cdr pair-tag))]) - (tbind ([x (Value (car arg*))] - [v (Value (cadr arg*))]) - (seq* ;;; car/cdr addresses are in the same - ;;; card as the pair address, so no - ;;; adjustment is necessary as was the - ;;; case with vectors and records. - (make-shortcut - (seq* - (make-conditional - (tag-test x pair-mask pair-tag) - (prm 'nop) - (prm 'interrupt)) - (prm 'mset x (K off) v) - (smart-dirty-vector-set x (cadr arg*))) - (Effect - (make-funcall (make-primref 'error) - (list (K op) (K "~s is not a pair") x)))))))] - [($string-set!) - (tbind ([x (Value (car arg*))]) - (let ([i (cadr arg*)] - [c (caddr arg*)]) - (record-case i - [(constant i) - (unless (fixnum? i) - (error who "invalid arg ~s to ~s" i op)) - (record-case c - [(constant c) - (unless (char? c) (err x)) - (prm 'bset/c x - (K (+ i (- disp-string-data string-tag))) - (K (char->integer c)))] - [else - (unless (= char-shift 8) - (error who "assumption about char-shift")) - (tbind ([c (Value c)]) - (prm 'bset/h x - (K (+ i (- disp-string-data string-tag))) - c))])] - [else - (tbind ([i (Value i)]) - (record-case c - [(constant c) - (unless (char? c) (err x)) - (prm 'bset/c x - (prm 'sra i (K fixnum-shift)) - (K (char->integer c)))] - [else - (unless (= char-shift 8) - (error who "assumption about char-shift")) - (tbind ([c (Value c)]) - (prm 'bset/h x - (prm 'int+ - (prm 'sra i (K fixnum-shift)) - (K (- disp-string-data string-tag))) - c))]))])))] - [($code-set!) - (tbind ([x (Value (car arg*))] - [i (Value (cadr arg*))] - [v (Value (caddr arg*))]) - (prm 'bset/h x - (prm 'int+ - (prm 'sra i (K fixnum-shift)) - (K (- disp-code-data vector-tag))) - (prm 'sll v (K (- 8 fixnum-shift)))))] - [($unset-interrupted!) ;;; PCB INTERRUPT - (prm 'mset pcr (K 40) (K 0))] - [($set-port-input-index! $set-port-output-index!) - (let ([off (case op - [($set-port-input-index!) disp-port-input-index] - [($set-port-output-index!) disp-port-output-index] - [else (err x)])]) - (tbind ([x (Value (car arg*))] - [v (Value (cadr arg*))]) - (prm 'mset x (K (- off vector-tag)) v)))] - [($set-port-input-size! $set-port-output-size!) - (let-values ([(sz-off idx-off) - (case op - [($set-port-input-size!) - (values disp-port-input-size - disp-port-input-index)] - [($set-port-output-size!) - (values disp-port-output-size - disp-port-output-index)] - [else (err x)])]) - (tbind ([x (Value (car arg*))] - [v (Value (cadr arg*))]) - (seq* - (prm 'mset x (K (- idx-off vector-tag)) (K 0)) - (prm 'mset x (K (- sz-off vector-tag)) v))))] - [($set-tcbucket-next! $set-tcbucket-val! $set-tcbucket-tconc!) - (tbind ([x (Value (car arg*))] - [v (Value (cadr arg*))]) - (mem-assign v x - (- (case op - [($set-tcbucket-tconc!) disp-tcbucket-tconc] - [($set-tcbucket-next!) disp-tcbucket-next] - [($set-tcbucket-val!) disp-tcbucket-val] - [else (err 'tcbucket!)]) - vector-tag)))] - [else - (if (primop? op) - (cogen-primop op 'E arg*) - (error who "invalid effect prim ~s" op))])] - [(forcall op arg*) - (make-forcall op (map Value arg*))] - [(funcall rator arg*) - (make-funcall (Function rator) (map Value arg*))] - [(jmpcall label rator arg*) - (make-jmpcall label (Value rator) (map Value arg*))] - [(mvcall rator x) - (make-mvcall (Value rator) (Clambda x Effect))] - [else (error who "invalid effect expr ~s" x)])) - ;;; - (define (tag-test x mask tag) - (tbind ([x x]) - (if mask - (prm '= - (prm 'logand x (K mask)) - (K tag)) - (prm '= x (K tag))))) - (define (sec-tag-test x pmask ptag smask stag) - (tbind ([t x]) - (make-conditional - (tag-test t pmask ptag) - (tag-test (prm 'mref t (K (- ptag))) smask stag) - (make-constant #f)))) - ;;; - (define (Pred x) - (record-case x - [(constant) x] - [(bind lhs* rhs* body) - (make-bind lhs* (map Value rhs*) (Pred body))] - [(conditional e0 e1 e2) - (make-conditional (Pred e0) (Pred e1) (Pred e2))] - [(seq e0 e1) - (make-seq (Effect e0) (Pred e1))] - [(fix lhs* rhs* body) - (handle-fix lhs* rhs* (Pred body))] - [(primcall op arg*) - (case op - [(eq?) (make-primcall '= (map Value arg*))] - [(null?) (prm '= (Value (car arg*)) (K nil))] - [(eof-object?) (prm '= (Value (car arg*)) (K eof))] - [(bwp-object?) (prm '= (Value (car arg*)) (K bwp-object))] - [(neq?) (make-primcall '!= (map Value arg*))] - [($fxzero?) (prm '= (Value (car arg*)) (K 0))] - [(zero?) - (tbind ([x (Value (car arg*))]) - (make-conditional - (tag-test x fixnum-mask fixnum-tag) - (prm '= x (K 0)) - (prm '!= - (make-funcall (Value (make-primref 'zero?)) (list x)) - (Value (K #f)))))] - [($unbound-object?) (prm '= (Value (car arg*)) (K unbound))] - [(pair?) - (tag-test (Value (car arg*)) pair-mask pair-tag)] - [(procedure?) - (tag-test (Value (car arg*)) closure-mask closure-tag)] - [(symbol?) - (tag-test (Value (car arg*)) symbol-mask symbol-tag)] - [(string?) - (tag-test (Value (car arg*)) string-mask string-tag)] - [(char?) - (tag-test (Value (car arg*)) char-mask char-tag)] - [(boolean?) - (tag-test (Value (car arg*)) bool-mask bool-tag)] - [(fixnum?) - (tag-test (Value (car arg*)) fixnum-mask fixnum-tag)] - [(vector?) - (sec-tag-test (Value (car arg*)) - vector-mask vector-tag fixnum-mask fixnum-tag)] - [($forward-ptr?) - (tbind ([x (Value (car arg*))]) (prm '= x (K -1)))] - [($record?) - (sec-tag-test (Value (car arg*)) - vector-mask vector-tag vector-mask vector-tag)] - [($code?) - (sec-tag-test (Value (car arg*)) - vector-mask vector-tag #f code-tag)] - [(input-port?) - (sec-tag-test (Value (car arg*)) - vector-mask vector-tag #f input-port-tag)] - [(output-port?) - (sec-tag-test (Value (car arg*)) - vector-mask vector-tag #f output-port-tag)] - [(port?) - (sec-tag-test (Value (car arg*)) - vector-mask vector-tag port-mask port-tag)] - [($record/rtd?) - (tbind ([t (Value (car arg*))] - [v (Value (cadr arg*))]) - (make-conditional - (tag-test t vector-mask vector-tag) - (prm '= (prm 'mref t (K (- vector-tag))) v) - (make-constant #f)))] - [(immediate?) - (tbind ([t (Value (car arg*))]) - (make-conditional - (tag-test t fixnum-mask fixnum-tag) - (make-constant #t) - (tag-test t 7 7)))] - [($fp-at-base) - (prm '= - (prm 'int+ - (prm 'mref pcr (K 12)) ;;; PCB FRAME-BASE - (K (- wordsize))) - fpr)] - [($interrupted?) - (prm '!= (prm 'mref pcr (K 40)) (K 0))] - [($fx= $char=) - (prm '= (Value (car arg*)) (Value (cadr arg*)))] - [($fx< $char<) - (prm '< (Value (car arg*)) (Value (cadr arg*)))] - [($fx> $char>) - (prm '> (Value (car arg*)) (Value (cadr arg*)))] - [($fx<= $char<=) - (prm '<= (Value (car arg*)) (Value (cadr arg*)))] - [($fx>= $char>=) - (prm '>= (Value (car arg*)) (Value (cadr arg*)))] - [(= < <= > >=) - (unless (= (length arg*) 2) - (error who "only binary ~s for now" op)) - (let ([cmp? - (case op - [(=) =] - [(<) <] - [(<=) <=] - [(>) >] - [(>=) >=] - [else (error who "unhandled op ~s" op)])]) - (let ([a (car arg*)] [b (cadr arg*)]) - (define (call a b) - (prm '!= (Value (K #f)) - (make-funcall - (Value (make-primref op)) - (list a b)))) - (record-case a - [(constant i) - (cond - [(fixnum? i) - (record-case b - [(constant j) - (if (fixnum? j) - (make-constant (cmp? i j)) - (call (Value a) (Value b)))] - [else - (tbind ([b (Value b)]) - (make-conditional - (tag-test b fixnum-mask fixnum-tag) - (prm op (Value a) b) - (call (Value a) b)))])] - [else - (call (Value a) (Value b))])] - [else - (record-case b - [(constant j) - (if (fixnum? j) - (tbind ([a (Value a)]) - (make-shortcut - (make-seq - (make-conditional - (tag-test a fixnum-mask fixnum-tag) - (make-primcall 'nop '()) - (make-primcall 'interrupt '())) - (prm op a (Value b))) - (call a (Value b)))) - (call (Value a) (Value b)))] - [else - (tbind ([a (Value a)] [b (Value b)]) - (make-conditional - (tag-test (prm 'logor a b) fixnum-mask fixnum-tag) - (prm op a b) - (call a b)))])])))] - [else (error who "pred prim ~a not supported" op)])] - [(mvcall rator x) - (make-mvcall (Value rator) (Clambda x Pred))] - [else (error who "invalid pred expr ~s" x)])) - ;;; - (define (err x) - (error who "invalid form ~s" (unparse x))) - ;;; - (define (align-code unknown-amt known-amt) - (prm 'sll - (prm 'sra - (prm 'int+ unknown-amt - (K (+ known-amt (sub1 object-alignment)))) - (K align-shift)) - (K align-shift))) - (define (remove-complex* ls k) - (let-values ([(lhs* rhs* arg*) - (let f ([ls ls]) - (cond - [(null? ls) (values '() '() '())] - [else - (let-values ([(lhs* rhs* arg*) - (f (cdr ls))]) - (let ([a (car ls)]) - (cond - [(or (var? a) (complex? a)) - (values lhs* rhs* (cons a arg*))] - [else - (let ([t (unique-var 'tmp)]) - (values - (cons t lhs*) - (cons (Value a) rhs*) - (cons t arg*)))])))]))]) - (cond - [(null? lhs*) - (k arg*)] - [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 - [(constant) (constant-rep x)] - [(var) x] - [(primref name) - (prm 'mref - (K (make-object name)) - (K (- disp-symbol-system-value symbol-tag)))] - [(code-loc) (make-constant x)] - [(closure) (make-constant x)] - [(bind lhs* rhs* body) - (make-bind lhs* (map Value rhs*) (Value body))] - [(fix lhs* rhs* body) - (handle-fix lhs* rhs* (Value body))] - [(conditional e0 e1 e2) - (make-conditional (Pred e0) (Value e1) (Value e2))] - [(seq e0 e1) - (make-seq (Effect e0) (Value e1))] - [(primcall op arg*) - (case op - [(void) (K void-object)] - [(eof-object) (K eof)] - [($car) - (tbind ([x (Value (car arg*))]) - (prm 'mref x (K (- disp-car pair-tag))))] - [($cdr) - (tbind ([x (Value (car arg*))]) - (prm 'mref x (K (- disp-cdr pair-tag))))] - [(car cdr) - (tbind ([x (Value (car arg*))]) - (make-shortcut - (make-seq - (make-conditional - (tag-test x pair-mask pair-tag) - (prm 'nop) - (prm 'interrupt)) - (prm 'mref x (K (- (if (eq? op 'car) disp-car disp-cdr) - pair-tag)))) - (Value - (make-funcall (make-primref 'error) - (list (K op) (K "~s is not a pair") x)))))] - [(primitive-ref) - (tbind ([x (Value (car arg*))]) - (prm 'mref x - (K (- disp-symbol-system-value symbol-tag))))] - [($symbol-string) - (tbind ([x (Value (car arg*))]) - (prm 'mref x - (K (- disp-symbol-string symbol-tag))))] - [($symbol-plist) - (tbind ([x (Value (car arg*))]) - (prm 'mref x - (K (- disp-symbol-plist symbol-tag))))] - [($symbol-value) - (tbind ([x (Value (car arg*))]) - (prm 'mref x - (K (- disp-symbol-value symbol-tag))))] - [($symbol-unique-string) - (tbind ([x (Value (car arg*))]) - (prm 'mref x - (K (- disp-symbol-unique-string symbol-tag))))] - [($make-symbol) - (tbind ([str (Value (car arg*))]) - (tbind ([x (prm 'alloc - (K (align symbol-size)) - (K symbol-tag))]) - (seq* - (prm 'mset x - (K (- disp-symbol-string symbol-tag)) - str) - (prm 'mset x - (K (- disp-symbol-unique-string symbol-tag)) - (K 0)) - (prm 'mset x - (K (- disp-symbol-value symbol-tag)) - (K unbound)) - (prm 'mset x - (K (- disp-symbol-plist symbol-tag)) - (K nil)) - (prm 'mset x - (K (- disp-symbol-system-value symbol-tag)) - (K unbound)) - (prm 'mset x - (K (- disp-symbol-function symbol-tag)) - (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 - [(null? arg*) (K nil)] - [else - (let ([t* (map (lambda (x) (unique-var 't)) arg*)] - [n (length arg*)]) - (make-bind t* (map Value arg*) - (tbind ([v (prm 'alloc - (K (align (* n pair-size))) - (K pair-tag))]) - (seq* - (prm 'mset v (K (- disp-car pair-tag)) (car t*)) - (prm 'mset v - (K (- (+ disp-cdr (* (sub1 n) pair-size)) pair-tag)) - (K nil)) - (let f ([t* (cdr t*)] [i pair-size]) - (cond - [(null? t*) v] - [else - (make-seq - (tbind ([tmp (prm 'int+ v (K i))]) - (make-seq - (prm 'mset tmp - (K (- disp-car pair-tag)) - (car t*)) - (prm 'mset tmp - (K (+ disp-cdr (- pair-size) (- pair-tag))) - tmp))) - (f (cdr t*) (+ i pair-size)))]))))))])] - [(list*) - (let ([result - (let ([t* (map (lambda (x) (unique-var 't)) arg*)] - [n (length arg*)]) - (make-bind t* (map Value arg*) - (tbind ([v (prm 'alloc - (K (* (sub1 n) pair-size)) - (K pair-tag))]) - (seq* - (prm 'mset v (K (- disp-car pair-tag)) (car t*)) - (prm 'mset v - (K (- (+ disp-cdr (* (- n 2) pair-size)) pair-tag)) - (car (last-pair t*))) - (let f ([t* (cdr t*)] [i pair-size]) - (cond - [(null? (cdr t*)) v] - [else - (make-seq - (tbind ([tmp (prm 'int+ v (K i))]) - (make-seq - (prm 'mset tmp - (K (- disp-car pair-tag)) - (car t*)) - (prm 'mset tmp - (K (- (- disp-cdr pair-tag) pair-size)) - tmp))) - (f (cdr t*) (+ i pair-size)))]))))))]) - result)] - [(vector) - (let ([t* (map (lambda (x) (unique-var 't)) arg*)]) - (make-bind t* (map Value arg*) - (tbind ([v (prm 'alloc - (K (align (+ disp-vector-data - (* (length t*) - wordsize)))) - (K vector-tag))]) - (seq* - (prm 'mset v (K (- disp-vector-length vector-tag)) - (K (* (length t*) wordsize))) - (let f ([t* t*] [i (- disp-vector-data vector-tag)]) - (cond - [(null? t*) v] - [else - (make-seq - (prm 'mset v (K i) (car t*)) - (f (cdr t*) (+ i wordsize)))]))))))] - [($record) - (let ([rtd (car arg*)] [v* (map Value (cdr arg*))]) - (tbind ([rtd (Value rtd)]) - (let ([t* (map (lambda (x) (unique-var 'v)) v*)]) - (make-bind t* v* - (tbind ([t (prm 'alloc - (K (align - (+ disp-record-data - (* (length v*) wordsize)))) - (K vector-tag))]) - (seq* - (prm 'mset t - (K (- disp-record-rtd vector-tag)) - rtd) - (let f ([t* t*] - [i (- disp-record-data vector-tag)]) - (cond - [(null? t*) t] - [else - (make-seq - (prm 'mset t (K i) (car t*)) - (f (cdr t*) (+ i wordsize)))]))))))))] - [($vector-length) - (tbind ([x (Value (car arg*))]) - (prm 'mref x - (K (- disp-vector-length vector-tag))))] - [($make-vector) - (unless (= (length arg*) 1) - (error who "incorrect args to $make-vector")) - (let ([len (car arg*)]) - (record-case len - [(constant i) - (unless (fixnum? i) (error who "invalid ~s" x)) - (tbind ([v (prm 'alloc - (K (align (+ (* i wordsize) - disp-vector-data))) - (K vector-tag))]) - (seq* - (prm 'mset v - (K (- disp-vector-length vector-tag)) - (K (make-constant (* i fixnum-scale)))) - v))] - [else - (tbind ([len (Value len)]) - (tbind ([alen (align-code len disp-vector-data)]) - (tbind ([v (prm 'alloc alen (K vector-tag))]) - (seq* - (prm 'mset v - (K (- disp-vector-length vector-tag)) - len) - v))))]))] - [($string-length) - (tbind ([x (Value (car arg*))]) - (prm 'mref x - (K (- disp-string-length string-tag))))] - [($string-ref) - (tbind ([s (Value (car arg*))]) - (let ([i (cadr arg*)]) - (record-case i - [(constant i) - (unless (fixnum? i) (err x)) - (prm 'logor - (prm 'sll - (prm 'logand - (prm 'mref s - (K (+ i (- disp-string-data string-tag)))) - (K 255)) - (K char-shift)) - (K char-tag))] - [else - (tbind ([i (Value i)]) - (prm 'logor - (prm 'sll - (prm 'srl ;;; FIXME: bref - (prm 'mref s - (prm 'int+ - (prm 'sra i (K fixnum-shift)); - ;;; ENDIANNESS DEPENDENCY - (K (- disp-string-data - (- wordsize 1) - string-tag)))) - (K (* (- wordsize 1) 8))) - (K char-shift)) - (K char-tag)))])))] - [(string-ref) - (tbind ([s (Value (car arg*))]) - (let ([idx (cadr arg*)]) - (record-case idx - [(constant i) - (cond - [(and (fixnum? i) (fx>= i 0)) - (make-shortcut - (seq* - (make-conditional - (tag-test s string-mask string-tag) - (prm 'nop) - (prm 'interrupt)) - (tbind ([len - (prm 'mref s - (K (- disp-string-length string-tag)))]) - (make-conditional - (prm 'u< (K (* i fixnum-scale)) len) - (prm 'nop) - (prm 'interrupt))) - (Value (prm '$string-ref s idx))) - (Value - (make-funcall (make-primref 'string-ref) - (list s idx))))] - [else - (Value - (make-funcall (make-primref 'string-ref) - (list s idx)))])] - [else - (tbind ([i (Value idx)]) - (make-shortcut - (seq* - (make-conditional - (tag-test i fixnum-mask fixnum-tag) - (prm 'nop) - (prm 'interrupt)) - (make-conditional - (tag-test s string-mask string-tag) - (prm 'nop) - (prm 'interrupt)) - (tbind ([len - (prm 'mref s - (K (- disp-string-length string-tag)))]) - (make-conditional - (prm 'u< i len) - (prm 'nop) - (prm 'interrupt))) - (Value (prm '$string-ref s i))) - (Value - (make-funcall (make-primref 'string-ref) - (list s i)))))])))] - [($make-string) - (unless (= (length arg*) 1) (err x)) - (let ([n (car arg*)]) - (record-case n - [(constant n) - (unless (fixnum? n) (err x)) - (tbind ([s (prm 'alloc - (K (align (+ n 1 disp-string-data))) - (K string-tag))]) - (seq* - (prm 'mset s - (K (- disp-string-length string-tag)) - (K (* n fixnum-scale))) - (prm 'bset/c s - (K (+ n (- disp-string-data string-tag))) - (K 0)) - s))] - [else - (tbind ([n (Value n)]) - (tbind ([s (prm 'alloc - (align-code - (prm 'sra n (K fixnum-shift)) - (+ disp-string-data 1)) - (K string-tag))]) - (seq* - (prm 'mset s - (K (- disp-string-length string-tag)) - n) - (prm 'bset/c s - (prm 'int+ - (prm 'sra n (K fixnum-shift)) - (K (- disp-string-data string-tag))) - (K 0)) - s)))]))] - [($make-record) - (let ([rtd (car arg*)] [len (cadr arg*)]) - (tbind ([rtd (Value rtd)]) - (record-case len - [(constant i) - (unless (fixnum? i) - (error who "invalid make-rec ~s" len)) - (tbind ([t (prm 'alloc - (K (align (+ (* i wordsize) - disp-record-data))) - (K vector-tag))]) - (seq* - (prm 'mset t - (K (- disp-record-rtd vector-tag)) - rtd) - t))] - [else - (tbind ([len (Value len)]) - (tbind ([ln (align-code len disp-record-data)]) - (tbind ([t (prm 'alloc ln (K vector-tag))]) - (seq* - (prm 'mset t - (K (- disp-record-rtd vector-tag)) - rtd) - t))))])))] - [($record-rtd) - (tbind ([x (Value (car arg*))]) - (prm 'mref x - (K (- disp-record-rtd vector-tag))))] - [(cons) - (tbind ([a (Value (car arg*))] - [d (Value (cadr arg*))]) - (tbind ([t (prm 'alloc (K pair-size) (K pair-tag))]) - (seq* - (prm 'mset t (K (- disp-car pair-tag)) a) - (prm 'mset t (K (- disp-cdr pair-tag)) d) - t)))] - [($fxadd1) - (prm 'int+ (Value (car arg*)) (K (* 1 fixnum-scale)))] - [($fxsub1) - (prm 'int+ (Value (car arg*)) (K (* -1 fixnum-scale)))] - [($fx+) - (prm 'int+ (Value (car arg*)) (Value (cadr arg*)))] - [($fx-) - (prm 'int- (Value (car arg*)) (Value (cadr arg*)))] - [($fx*) - (let ([a (car arg*)] [b (cadr arg*)]) - (record-case a - [(constant a) - (unless (fixnum? a) (err x)) - (tbind ([b (Value b)]) - (prm 'int* b (K a)))] - [else - (record-case b - [(constant b) - (unless (fixnum? b) (err x)) - (tbind ([a (Value a)]) - (prm 'int* a (K b)))] - [else - (tbind ([a (Value a)] [b (Value b)]) - (prm 'int* a (prm 'sra b (K fixnum-shift))))])]))] - [($fxquotient) - (tbind ([a (Value (car arg*))] [b (Value (cadr arg*))]) - (prm 'sll (prm 'remainder a b) (K fixnum-shift)))] - [($fxmodulo) - (tbind ([a (Value (car arg*))] - [b (Value (cadr arg*))]) - (tbind ([c (prm 'logand b - (prm 'sra - (prm 'logxor b a) - (K (sub1 (* 8 wordsize)))))]) - (prm 'int+ c (prm 'quotient a b))))] - [($fxsll) - (let ([a (car arg*)] [c (cadr arg*)]) - (record-case c - [(constant i) - (if (fixnum? i) - (tbind ([a (Value a)]) - (prm 'sll a (K i))) - (error who "invalid arg to fxsll ~s" i))] - [else - (tbind ([a (Value a)] [c (Value c)]) - (prm 'sll a (prm 'sra c (K fixnum-shift))))]))] - [($fxsra) - (let ([a (car arg*)] [c (cadr arg*)]) - (record-case c - [(constant i) - (if (fixnum? i) - (tbind ([a (Value a)]) - (prm 'sra a (K i))) - (error who "invalid arg to fxsra ~s" i))] - [else - (tbind ([a (Value a)] [c (Value c)]) - (prm 'logand - (prm 'sra a - (prm 'sra c (K fixnum-shift))) - (K (* -1 fixnum-scale))))]))] - [($fxlogand) - (prm 'logand (Value (car arg*)) (Value (cadr arg*)))] - [(pointer-value) - (prm 'logand (Value (car arg*)) (K (* -1 fixnum-scale)))] - [($fxlogxor) - (prm 'logxor (Value (car arg*)) (Value (cadr arg*)))] - [($fxlogor) - (prm 'logor (Value (car arg*)) (Value (cadr arg*)))] - [($fxlognot) - (Value (prm '$fxlogxor (car arg*) (K -1)))] - [(+) - (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) - (if (fixnum? i) - (tbind ([b (Value b)]) - (make-shortcut - (make-seq - (make-conditional - (tag-test b fixnum-mask fixnum-tag) - (make-primcall 'nop '()) - (make-primcall 'interrupt '())) - (prm primname (Value a) b)) - (make-funcall (Value (make-primref op)) - (list (Value a) b)))) - (make-funcall (Value (make-primref op)) - (list (Value a) b)))] - [else - (record-case b - [(constant i) - (if (fixnum? i) - (tbind ([a (Value a)]) - (make-shortcut - (make-seq - (make-conditional - (tag-test a fixnum-mask fixnum-tag) - (make-primcall 'nop '()) - (make-primcall 'interrupt '())) - (prm primname a (Value b))) - (make-funcall (Value (make-primref op)) - (list a (Value b))))) - (make-funcall (Value (make-primref op)) - (list a (Value b))))] - [else - (tbind ([a (Value a)] - [b (Value b)]) - (make-shortcut - (make-seq - (make-conditional - (tag-test (prm 'logor a b) fixnum-mask fixnum-tag) - (make-primcall 'nop '()) - (make-primcall 'interrupt '())) - (prm primname a b)) - (make-funcall (Value (make-primref op)) - (list a b))))])])) - (cond - [(null? arg*) (K 0)] - [(ormap (lambda (x) - (record-case x - [(constant i) (not (number? i))] - [else #f])) arg*) - (make-funcall (Value (make-primref op)) (map Value arg*))] - [(= (length arg*) 1) ;;; FIXME: do something better - (handle-binary (K ID) (car arg*))] - [(= (length arg*) 2) - (handle-binary (car arg*) (cadr arg*))] - [else - (remove-complex* arg* - (lambda (arg*) - (Value - (let f ([a (car arg*)] [d (cdr arg*)]) - (cond - [(null? d) a] - [else (f (prm op a (car d)) (cdr d))])))))]))] - [(-) - (let () - (define (handle-binary a b) - (record-case a - [(constant i) - (if (fixnum? i) - (tbind ([b (Value b)]) - (make-shortcut - (make-seq - (make-conditional - (tag-test b fixnum-mask fixnum-tag) - (make-primcall 'nop '()) - (make-primcall 'interrupt '())) - (prm 'int-/overflow (Value a) b)) - (make-funcall (Value (make-primref '-)) - (list (Value a) b)))) - (make-funcall (Value (make-primref '-)) - (list (Value a) b)))] - [else - (record-case b - [(constant i) - (if (fixnum? i) - (tbind ([a (Value a)]) - (make-shortcut - (make-seq - (make-conditional - (tag-test a fixnum-mask fixnum-tag) - (make-primcall 'nop '()) - (make-primcall 'interrupt '())) - (prm 'int-/overflow a (Value b))) - (make-funcall (Value (make-primref '-)) - (list a (Value b))))) - (make-funcall (Value (make-primref '-)) - (list a (Value b))))] - [else - (tbind ([a (Value a)] - [b (Value b)]) - (make-shortcut - (make-seq - (make-conditional - (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 '-)) - (list a b))))])])) - (cond - [(or (null? arg*) - (ormap - (lambda (x) - (record-case x - [(constant i) (not (number? i))] - [else #f])) arg*)) - (make-funcall (Value (make-primref '-)) (map Value arg*))] - [(= (length arg*) 1) - (handle-binary (K 0) (car arg*))] - [(= (length arg*) 2) - (handle-binary (car arg*) (cadr arg*))] - [else - (remove-complex* arg* - (lambda (arg*) - (Value - (let f ([a (car arg*)] [d (cdr arg*)]) - (cond - [(null? d) a] - [else (f (prm '- a (car d)) (cdr d))])))))]))] - [($char->fixnum) - (tbind ([x (Value (car arg*))]) - (prm 'sra x - (K (- char-shift fixnum-shift))))] - [($fixnum->char) - (tbind ([x (Value (car arg*))]) - (prm 'logor - (prm 'sll x (K (- char-shift fixnum-shift))) - (K char-tag)))] - [($current-frame) ;; PCB NEXT-CONTINUATION - (prm 'mref pcr (K 20))] - [($arg-list) ;; PCB ARGS-LIST - (prm 'mref pcr (K 32))] - [($seal-frame-and-call) - (tbind ([proc (Value (car arg*))]) - (tbind ([k (prm 'alloc - (K continuation-size) - (K vector-tag))]) - (tbind ([base (prm 'int+ ;;; PCB BASE - (prm 'mref pcr (K 12)) - (K (- wordsize)))]) - (tbind ([underflow-handler - (prm 'mref base (K 0))]) - (seq* - (prm 'mset k - (K (- vector-tag)) - (K continuation-tag)) - (prm 'mset k - (K (- disp-continuation-top vector-tag)) - fpr) - (prm 'mset k - (K (- disp-continuation-next vector-tag)) - (prm 'mref pcr (K 20))) ;;; PCB NEXT CONT - (prm 'mset k - (K (- disp-continuation-size vector-tag)) - (prm 'int- base fpr)) - (prm 'mset pcr (K 20) k) - (prm 'mset pcr (K 12) fpr) - (make-primcall '$call-with-underflow-handler - (list underflow-handler proc k)))))))] - [($frame->continuation) - (tbind ([arg (Value (car arg*))]) - (tbind ([t (prm 'alloc - (K (align (+ disp-closure-data wordsize))) - (K closure-tag))]) - (seq* - (prm 'mset t - (K (- disp-closure-code closure-tag)) - (K (make-code-loc SL_continuation_code))) - (prm 'mset t - (K (- disp-closure-data closure-tag)) - arg) - t)))] - [($make-call-with-values-procedure) - (K (make-closure (make-code-loc SL_call_with_values) '()))] - [($make-values-procedure) - (K (make-closure (make-code-loc SL_values) '()))] - [($cpref) - (let ([a0 (car arg*)] [a1 (cadr arg*)]) - (record-case a1 - [(constant i) - (unless (fixnum? i) (err x)) - (tbind ([a0 (Value a0)]) - (prm 'mref a0 - (K (+ (- disp-closure-data closure-tag) - (* i wordsize)))))] - [else (err x)]))] - [($vector-ref $record-ref) - (let ([a0 (car arg*)] [a1 (cadr arg*)]) - (record-case a1 - [(constant i) - (unless (fixnum? i) (err x)) - (tbind ([a0 (Value a0)]) - (prm 'mref a0 - (K (+ (- disp-vector-data vector-tag) - (* i wordsize)))))] - [else - (tbind ([a0 (Value a0)] [a1 (Value a1)]) - (prm 'mref (prm 'int+ a0 a1) - (K (- disp-vector-data vector-tag))))]))] - [($closure-code) - (tbind ([x (Value (car arg*))]) - (prm 'int+ - (prm 'mref x - (K (- disp-closure-code closure-tag))) - (K (- vector-tag disp-code-data))))] - [($code-freevars) - (tbind ([x (Value (car arg*))]) - (prm 'mref x - (K (- disp-code-freevars vector-tag))))] - [(top-level-value) - (let ([sym - (record-case (car arg*) - [(constant c) - (if (symbol? c) c #f)] - [else #f])]) - (cond - [sym - (tbind ([v (Value (prm '$symbol-value (car arg*)))]) - (make-shortcut - (make-seq - (make-conditional - (Pred (prm '$unbound-object? v)) - (prm 'interrupt) - (prm 'nop)) - v) - (Value - (make-funcall - (make-primref 'top-level-value-error) - (list (car arg*))))))] - [sym - (Value - (tbind ([v (prm '$symbol-value (car arg*))]) - (make-conditional - (make-primcall '$unbound-object? (list v)) - (make-funcall - (make-primref 'top-level-value-error) - (list (car arg*))) - v)))] - [else - (Value - (tbind ([sym (car arg*)]) - (make-conditional - (make-primcall 'symbol? (list sym)) - (tbind ([v (make-primcall - '$symbol-value (list sym))]) - (make-conditional - (make-primcall '$unbound-object? (list v)) - (make-funcall - (make-primref 'top-level-value-error) - (list sym)) - v)) - (make-funcall - (make-primref 'top-level-value-error) - (list sym)))))]))] - [($make-port/input $make-port/output $make-port/both) - (unless (= (length arg*) 7) (err x)) - (let ([tag - (case op - [($make-port/input) input-port-tag] - [($make-port/output) output-port-tag] - [($make-port/both) input/output-port-tag] - [else (err x)])] - [t* (map (lambda (x) (unique-var 'tmp)) arg*)]) - (make-bind t* (map Value arg*) - (apply - (lambda (handler buf/i idx/i sz/i buf/o idx/o sz/o) - (tbind ([p (prm 'alloc - (K (align port-size)) - (K vector-tag))]) - (seq* - (prm 'mset p - (K (- vector-tag)) - (K tag)) - (prm 'mset p - (K (- disp-port-handler vector-tag)) - handler) - (prm 'mset p - (K (- disp-port-input-buffer vector-tag)) - buf/i) - (prm 'mset p - (K (- disp-port-input-index vector-tag)) - idx/i) - (prm 'mset p - (K (- disp-port-input-size vector-tag)) - sz/i) - (prm 'mset p - (K (- disp-port-output-buffer vector-tag)) - buf/o) - (prm 'mset p - (K (- disp-port-output-index vector-tag)) - idx/o) - (prm 'mset p - (K (- disp-port-output-size vector-tag)) - sz/o) - p))) - t*)))] - [($port-handler - $port-input-buffer $port-output-buffer - $port-input-index $port-output-index - $port-input-size $port-output-size) - (let ([off (case op - [($port-handler) disp-port-handler] - [($port-input-buffer) disp-port-input-buffer] - [($port-input-index) disp-port-input-index] - [($port-input-size) disp-port-input-size] - [($port-output-buffer) disp-port-output-buffer] - [($port-output-index) disp-port-output-index] - [($port-output-size) disp-port-output-size] - [else (err x)])]) - (tbind ([p (Value (car arg*))]) - (prm 'mref p (K (- off vector-tag)))))] - [($code-reloc-vector) - (tbind ([x (Value (car arg*))]) - (prm 'mref x (K (- disp-code-relocsize vector-tag))))] - [($code-size) - (tbind ([x (Value (car arg*))]) - (prm 'mref x (K (- disp-code-instrsize vector-tag))))] - [($code->closure) - (tbind ([x (Value (car arg*))]) - (tbind ([v (prm 'alloc - (K (align (+ 0 disp-closure-data))) - (K closure-tag))]) - (seq* - (prm 'mset v - (K (- disp-closure-code closure-tag)) - (prm 'int+ x - (K (- disp-code-data vector-tag)))) - v)))] - [($code-ref) - (tbind ([x (Value (car arg*))] - [i (Value (cadr arg*))]) - (prm 'sll - (prm 'logand - (prm 'mref x - (prm 'int+ - (prm 'sra i (K fixnum-shift)) - (K (- disp-code-data vector-tag)))) - (K 255)) - (K fixnum-shift)))] - [($make-tcbucket) - (tbind ([tconc (Value (car arg*))] - [key (Value (cadr arg*))] - [val (Value (caddr arg*))] - [next (Value (cadddr arg*))]) - (tbind ([x (prm 'alloc - (K (align tcbucket-size)) - (K vector-tag))]) - (seq* - (prm 'mset x - (K (- disp-tcbucket-tconc vector-tag)) - tconc) - (prm 'mset x - (K (- disp-tcbucket-key vector-tag)) - key) - (prm 'mset x - (K (- disp-tcbucket-val vector-tag)) - val) - (prm 'mset x - (K (- disp-tcbucket-next vector-tag)) - next) - x)))] - [($tcbucket-key) - (tbind ([x (Value (car arg*))]) - (prm 'mref x (K (- disp-tcbucket-key vector-tag))))] - [($tcbucket-val) - (tbind ([x (Value (car arg*))]) - (prm 'mref x (K (- disp-tcbucket-val vector-tag))))] - [($tcbucket-next) - (tbind ([x (Value (car arg*))]) - (prm 'mref x (K (- disp-tcbucket-next vector-tag))))] - [($procedure-check) - (tbind ([x (Value (car arg*))]) - (make-shortcut - (make-seq - (make-conditional - (tag-test x closure-mask closure-tag) - (prm 'nop) - (prm 'interrupt)) - x) - (Value - (make-funcall (make-primref 'error) - (list (make-constant 'apply) - (make-constant "~s is not a procedure") - x)))))] - [else - (if (primop? op) - (cogen-primop op 'V arg*) - (error who "invalid value prim ~s" op))])] - [(forcall op arg*) - (make-forcall op (map Value arg*))] - [(funcall rator arg*) - (make-funcall (Function rator) (map Value arg*))] - [(jmpcall label rator arg*) - (make-jmpcall label (Value rator) (map Value arg*))] - [(mvcall rator x) - (make-mvcall (Value rator) (Clambda x Value))] - [else (error who "invalid value expr ~s" x)])) - ;;; - (define (ClambdaCase x k) - (record-case x - [(clambda-case info body) - (make-clambda-case info (k body))] - [else (error who "invalid clambda-case ~s" x)])) - ;;; - (define (Clambda x k) - (record-case x - [(clambda label case* free*) - (make-clambda label - (map (lambda (x) (ClambdaCase x k)) case*) - 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) - (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) - (Program x)) - - - - (define parameter-registers '(%edi)) (define return-value-register '%eax) @@ -2337,6 +792,13 @@ (define (impose-calling-convention/evaluation-order x) (define who 'impose-calling-convention/evaluation-order) ;;; + (define-syntax car + (syntax-rules () + [(_ x) + (let ([t x]) + (if (pair? t) + (#%car t) + (error 'car "not a pair ~s in ~s" t '(car x))))])) ;;; (define (S* x* k) (cond @@ -2447,6 +909,7 @@ [(primcall op rands) (case op [(alloc) + (unless (pair? rands) (error 'car "h1")) (S (car rands) (lambda (size) (make-seq @@ -2461,9 +924,11 @@ [(mref) (S* rands (lambda (rands) + (unless (pair? rands) (error 'car "h2")) (make-set d (make-disp (car rands) (cadr rands)))))] [(logand logxor logor int+ int- int* int-/overflow int+/overflow int*/overflow) + (unless (pair? rands) (error 'car "h3")) (make-seq (V d (car rands)) (S (cadr rands) @@ -2472,6 +937,7 @@ [(remainder) (S* rands (lambda (rands) + (unless (pair? rands) (error 'car "h4")) (seq* (make-set eax (car rands)) (make-asm-instr 'cltd edx eax) @@ -2480,12 +946,14 @@ [(quotient) (S* rands (lambda (rands) + (unless (pair? rands) (error 'car "h5")) (seq* (make-set eax (car rands)) (make-asm-instr 'cltd edx eax) (make-asm-instr 'idiv edx (cadr rands)) (make-set d edx))))] [(sll sra srl) + (unless (pair? rands) (error 'car "h6 ~s" x)) (let ([a (car rands)] [b (cadr rands)]) (cond [(constant? b) @@ -2526,9 +994,11 @@ (assign* (cdr lhs*) (cdr rhs*) ac))])) ;;; (define (VT x) - (make-seq - (V return-value-register x) - (make-primcall 'return (list return-value-register)))) + (S x + (lambda (x) + (make-seq + (make-set return-value-register x) + (make-primcall 'return (list return-value-register)))))) ;;; impose effect (define (E x) (record-case x @@ -2568,6 +1038,7 @@ [(bind lhs* rhs* e) (do-bind lhs* rhs* (P e))] [(primcall op rands) + (unless (pair? rands) (error 'car "ha ~s" x)) (let ([a (car rands)] [b (cadr rands)]) (cond [(and (constant? a) (constant? b)) @@ -2634,6 +1105,7 @@ [(primcall op rands) (case op [($call-with-underflow-handler) + (unless (pair? rands) (error 'car "h6")) (let ([handler (car rands)] [proc (cadr rands)] [k (caddr rands)]) @@ -3236,13 +1708,13 @@ [(shortcut body handler) (let-values ([(vsh rsh fsh nsh) (P handler vst rst fst nst - vsf rsf fsf nsf - vsu rsu fsu nsu)]) + vsf rsf fsf nsf + vsu rsu fsu nsu)]) (parameterize ([exception-live-set (vector vsh rsh fsh nsh)]) (P body vst rst fst nst - vsf rsf fsf nsf - vsu rsu fsu nsu)))] + vsf rsf fsf nsf + vsu rsu fsu nsu)))] [else (error who "invalid pred ~s" (unparse x))])) (define (T x) (record-case x @@ -4467,24 +2939,24 @@ (define (alt-cogen x) (verify-new-cogen-input x) (let* ( - ;[foo (printf "0")] - [x (remove-primcalls x)] - ;[foo (printf "1")] - [x (eliminate-fix x)] - ;[foo (printf "2")] - [x (normalize-context x)] - ;[foo (printf "3")] - [x (remove-complex-operands x)] - [x (specify-representation x)] - ;[foo (printf "4")] - [x (impose-calling-convention/evaluation-order x)] - ;[foo (printf "5")] - [x (assign-frame-sizes x)] - ;[foo (printf "6")] - [x (color-by-chaitin x)] - ;[foo (printf "7")] - [ls (flatten-codes x)] - ;[foo (printf "8")] + ;[foo (printf "0")] + [x (remove-primcalls x)] + ;[foo (printf "1")] + [x (eliminate-fix x)] + ;[foo (printf "2")] + ; [x (normalize-context x)] + ;[foo (printf "3")] + ; [x (remove-complex-operands x)] + [x (specify-representation x)] + ;[foo (printf "4")] + [x (impose-calling-convention/evaluation-order x)] + ;[foo (printf "5")] + [x (assign-frame-sizes x)] + ;[foo (printf "6")] + [x (color-by-chaitin x)] + ;[foo (printf "7")] + [ls (flatten-codes x)] + ;[foo (printf "8")] ) (when #f (parameterize ([gensym-prefix "L"] diff --git a/src/libcore.ss b/src/libcore.ss index 54c452c..03c32a0 100644 --- a/src/libcore.ss +++ b/src/libcore.ss @@ -317,18 +317,14 @@ reference-implementation: (and s #t))))) -;;; OLD (primitive-set! 'top-level-value -;;; OLD (lambda (x) -;;; OLD (unless (symbol? x) -;;; OLD (error 'top-level-value "~s is not a symbol" x)) -;;; OLD (let ([v ($symbol-value x)]) -;;; OLD (when ($unbound-object? v) -;;; OLD (error 'top-level-value "unbound variable ~s" x)) -;;; OLD v))) - (primitive-set! 'top-level-value (lambda (x) - (top-level-value x))) + (unless (symbol? x) + (error 'top-level-value "~s is not a symbol" x)) + (let ([v ($symbol-value x)]) + (when ($unbound-object? v) + (error 'top-level-value "unbound variable ~s" x)) + v))) (primitive-set! 'top-level-bound? (lambda (x) @@ -1861,4 +1857,3 @@ reference-implementation: (convert-sign x ($string-length x))] [else (error 'string->number "~s is not a string" x)]))) -#!eof diff --git a/src/libnumerics.ss b/src/libnumerics.ss index 64150aa..61a6c87 100644 --- a/src/libnumerics.ss +++ b/src/libnumerics.ss @@ -240,6 +240,12 @@ (cond [(flonum? y) (foreign-call "ikrt_fl_div" (fixnum->flonum x) y)] + [(fixnum? y) + (let ([q (fxquotient x y)] + [r (fxremainder x y)]) + (if (fxzero? r) + q + (error '/ "no ratnum for ~s/~s" x y)))] [else (error '/ "unsupported ~s ~s" x y)])] [else (error '/ "unsupported ~s ~s" x y)]))) @@ -345,8 +351,13 @@ [(flonum? x) #f] [else (error 'rational? "~s is not a number" x)]))) - (define integer? - (lambda (x) (number? x))) + (define integer? + (lambda (x) + (cond + [(fixnum? x) #t] + [(bignum? x) #t] + [(flonum? x) (error 'integer "dunno for ~s" x)] + [else #f]))) (define exact? (lambda (x) @@ -706,7 +717,12 @@ (cond [(fixnum? x) (eq? x 0)] [(bignum? x) #f] - [else (error 'zero? "~s is not a number" x)]))) + [(flonum? x) (= x (exact->inexact 0))] + [else (error 'zero? "tag=~s / ~s is not a number" + (#%$fxlogand 255 + (#%$fxsll x 2)) + (#%$fxlogand x -1) + )]))) (primitive-set! 'expt (lambda (n m) diff --git a/src/libtokenizer.ss b/src/libtokenizer.ss index e1931b8..e60d953 100644 --- a/src/libtokenizer.ss +++ b/src/libtokenizer.ss @@ -794,7 +794,6 @@ (unless (eof-object? x) (eval x) (read-and-eval p eval))))) - (primitive-set! 'load (case-lambda [(x) (load x eval)] diff --git a/src/pass-specify-rep-primops.ss b/src/pass-specify-rep-primops.ss index a01fc15..68a255b 100644 --- a/src/pass-specify-rep-primops.ss +++ b/src/pass-specify-rep-primops.ss @@ -89,6 +89,10 @@ [(P x) (prm '= (T x) (K nil))] [(E x) (nop)]) +(define-primop not safe + [(P x) (prm '= (T x) (K bool-f))] + [(E x) (nop)]) + (define-primop eof-object safe [(V) (K eof)] [(P) (K #t)] @@ -132,6 +136,43 @@ [(P) (K #t)] [(E) (nop)]) +(define-primop $memq safe + [(P x ls) + (record-case ls + [(constant ls) + (cond + [(not (list? ls)) (interrupt)] + [else + (with-tmp ([x (T x)]) + (let f ([ls ls]) + (cond + [(null? ls) (K #f)] + [(null? (cdr ls)) (prm '= x (T (K (car ls))))] + [else + (make-conditional + (prm '= x (T (K (car ls)))) + (K #t) + (f (cdr ls)))])))])] + [else (interrupt)])] + [(V x ls) + (record-case ls + [(constant ls) + (cond + [(not (list? ls)) (interrupt)] + [else + (with-tmp ([x (T x)]) + (let f ([ls ls]) + (cond + [(null? ls) (K bool-f)] + [else + (make-conditional + (prm '= x (T (K (car ls)))) + (T (K ls)) + (f (cdr ls)))])))])] + [else (interrupt)])] + [(E x ls) (nop)]) + + /section) (section ;;; pairs @@ -344,7 +385,7 @@ (prm 'int+ (T x) (T i)) (- disp-vector-data vector-tag))])]) -#;(define-primop vector-set! safe +(define-primop vector-set! safe [(E x i v) (seq* (vector-range-check x i) @@ -478,6 +519,15 @@ (with-tmp ([v (cogen-value-$symbol-value x)]) (interrupt-when (cogen-pred-$unbound-object? v))))])]) + +(define-primop $init-symbol-function! unsafe + [(E x v) + (with-tmp ([x (T x)] [v (T v)]) + (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))]) + + /section) (section ;;; fixnums @@ -619,12 +669,20 @@ (define (or* a a*) (cond [(null? a*) a] + [(constant? (car a*)) (or* a (cdr a*))] [else (or* (prm 'logor a (T (car a*))) (cdr a*))])) (define (assert-fixnums a a*) - (interrupt-unless (tag-test (or* (T a) a*) fixnum-mask fixnum-tag))) + (cond + [(constant? a) + (if (null? a*) + (nop) + (assert-fixnums (car a*) (cdr a*)))] + [else + (interrupt-unless + (tag-test (or* (T a) a*) fixnum-mask fixnum-tag))])) -(define (fold-p op a a*) +(define (fixnum-fold-p op a a*) (cond [(or (non-fixnum? a) (ormap non-fixnum? a*)) (interrupt)] [else @@ -640,40 +698,40 @@ (f b (cdr a*)) (K #f)))])))])) -(define (fold-e a a*) +(define (fixnum-fold-e a a*) (cond [(or (non-fixnum? a) (ormap non-fixnum? a*)) (interrupt)] [else (assert-fixnums a a*)])) (define-primop = safe [(P) (interrupt)] - [(P a . a*) (fold-p '= a a*)] + [(P a . a*) (fixnum-fold-p '= a a*)] [(E) (interrupt)] - [(E a . a*) (fold-e a a*)]) + [(E a . a*) (fixnum-fold-e a a*)]) (define-primop < safe [(P) (interrupt)] - [(P a . a*) (fold-p '< a a*)] + [(P a . a*) (fixnum-fold-p '< a a*)] [(E) (interrupt)] - [(E a . a*) (fold-e a a*)]) + [(E a . a*) (fixnum-fold-e a a*)]) (define-primop <= safe [(P) (interrupt)] - [(P a . a*) (fold-p '<= a a*)] + [(P a . a*) (fixnum-fold-p '<= a a*)] [(E) (interrupt)] - [(E a . a*) (fold-e a a*)]) + [(E a . a*) (fixnum-fold-e a a*)]) (define-primop > safe [(P) (interrupt)] - [(P a . a*) (fold-p '> a a*)] + [(P a . a*) (fixnum-fold-p '> a a*)] [(E) (interrupt)] - [(E a . a*) (fold-e a a*)]) + [(E a . a*) (fixnum-fold-e a a*)]) (define-primop >= safe [(P) (interrupt)] - [(P a . a*) (fold-p '>= a a*)] + [(P a . a*) (fixnum-fold-p '>= a a*)] [(E) (interrupt)] - [(E a . a*) (fold-e a a*)]) + [(E a . a*) (fixnum-fold-e a a*)]) (define-primop - safe [(V a) @@ -715,6 +773,12 @@ [(E) (nop)] [(E a . a*) (assert-fixnums a a*)]) +(define-primop zero? safe + [(P x) + (seq* + (interrupt-unless (cogen-pred-fixnum? x)) + (cogen-pred-$fxzero? x))] + [(E x) (interrupt-unless (cogen-pred-fixnum? x))]) /section) @@ -724,7 +788,7 @@ [(P x) (sec-tag-test (T x) vector-mask vector-tag vector-mask vector-tag)] [(E x) (nop)]) -#;(define-primop $record/rtd? unsafe +(define-primop $record/rtd? unsafe [(P x rtd) (make-conditional (tag-test (T x) vector-mask vector-tag) @@ -762,9 +826,13 @@ [(P x i) (cogen-pred-$vector-ref x i)]) (define-primop $record-set! unsafe - [(V x i v) (cogen-value-$vector-set! x i v)] + [(V x i v) + (seq* (cogen-effect-$vector-set! x i v) + (K void-object))] [(E x i v) (cogen-effect-$vector-set! x i v)] - [(P x i v) (cogen-pred-$vector-set! x i v)]) + [(P x i v) + (seq* (cogen-effect-$vector-set! x i v) + (K #t))]) (define-primop $record unsafe [(V rtd . v*) @@ -826,6 +894,72 @@ [(P x) (K #t)] [(E x) (nop)]) +(define (non-char? x) + (record-case x + [(constant i) (not (char? i))] + [else #f])) + +(define (assert-chars a a*) + (cond + [(constant? a) + (if (null? a*) + (nop) + (assert-chars (car a*) (cdr a*)))] + [else + (interrupt-unless + (tag-test (or* (T a) a*) char-mask char-tag))])) + +(define (char-fold-p op a a*) + (cond + [(or (non-char? a) (ormap non-char? a*)) (interrupt)] + [else + (seq* + (assert-chars a a*) + (let f ([a a] [a* a*]) + (cond + [(null? a*) (K #t)] + [else + (let ([b (car a*)]) + (make-conditional + (prm op (T a) (T b)) + (f b (cdr a*)) + (K #f)))])))])) + +(define (char-fold-e a a*) + (cond + [(or (non-char? a) (ormap non-char? a*)) (interrupt)] + [else (assert-chars a a*)])) + +(define-primop char=? safe + [(P) (interrupt)] + [(P a . a*) (char-fold-p '= a a*)] + [(E) (interrupt)] + [(E a . a*) (char-fold-e a a*)]) + +(define-primop char? safe + [(P) (interrupt)] + [(P a . a*) (char-fold-p '> a a*)] + [(E) (interrupt)] + [(E a . a*) (char-fold-e a a*)]) + +(define-primop char>=? safe + [(P) (interrupt)] + [(P a . a*) (char-fold-p '>= a a*)] + [(E) (interrupt)] + [(E a . a*) (char-fold-e a a*)]) + /section) (section ;;; strings @@ -1192,21 +1326,7 @@ #!eof - [($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)))] - [(zero?) - (tbind ([x (Value (car arg*))]) - (make-conditional - (tag-test x fixnum-mask fixnum-tag) - (prm '= x (K 0)) - (prm '!= - (make-funcall (Value (make-primref 'zero?)) (list x)) - (Value (K #f)))))] [($procedure-check) (tbind ([x (Value (car arg*))]) (make-shortcut diff --git a/src/pass-specify-rep.ss b/src/pass-specify-rep.ss index 14d9790..e310e03 100644 --- a/src/pass-specify-rep.ss +++ b/src/pass-specify-rep.ss @@ -17,7 +17,7 @@ (define fixnum-tag 0) (define fixnum-mask 3)) -(module (specify-representation) +(module (specify-representation primop?) (import object-representation) (define cookie (gensym)) (define (primop? x) @@ -34,7 +34,8 @@ [(not (PH-interruptable? p)) (parameterize ([interrupt-handler (lambda () - (error 'cogen "~s is uninterruptable" x))]) + (error 'cogen "~s ~s is uninterruptable in ~s" + x args ctxt))]) (k))] [else (let ([interrupted? #f]) @@ -44,14 +45,28 @@ (k))]) (cond [(not interrupted?) body] - [(or (eq? ctxt 'V) (eq? ctxt 'E)) - (make-shortcut body - (make-funcall (V (K x)) args))] + [(eq? ctxt 'V) + (let ([h (make-funcall (V (make-primref x)) args)]) + (if (record-case body + [(primcall op) (eq? op 'interrupt)] + [else #f]) + h + (make-shortcut body h)))] + [(eq? ctxt 'E) + (let ([h (make-funcall (V (make-primref x)) args)]) + (if (record-case body + [(primcall op) (eq? op 'interrupt)] + [else #f]) + h + (make-shortcut body h)))] [(eq? ctxt 'P) - (make-shortcut body - (prm '!= - (make-funcall (V (K x)) args) - (K bool-f)))] + (let ([h (prm '!= (make-funcall (V (make-primref x)) args) + (K bool-f))]) + (if (record-case body + [(primcall op) (eq? op 'interrupt)] + [else #f]) + h + (make-shortcut body h)))] [else (error 'with-interrupt-handler "invalid context ~s" ctxt)])))])) (define-syntax with-tmp (lambda (x) @@ -141,8 +156,7 @@ (with-tmp ([t (apply (PH-v-handler p) args)]) (prm 'nop))] [else (error 'cogen-primop "~s is not handled" x)])] - [else (error 'cogen-primop "invalid context ~s" - ctxt)]))))))] + [else (error 'cogen-primop "invalid context ~s" ctxt)]))))))] [else (error 'cogen-primop "~s is not a prim" x)])) (define-syntax define-primop @@ -315,7 +329,10 @@ (define (P x) (record-case x - [(constant) x] + [(constant c) (if c (K #t) (K #f))] + [(primref) (K #t)] + [(code-loc) (K #t)] + [(closure) (K #t)] [(bind lhs* rhs* body) (make-bind lhs* (map V rhs*) (P body))] [(conditional e0 e1 e2) @@ -326,10 +343,19 @@ (handle-fix lhs* rhs* (P body))] [(primcall op arg*) (cogen-primop op 'P arg*)] + [(var) (prm '!= (V x) (V (K #f)))] + [(funcall) (prm '!= (V x) (V (K #f)))] + [(jmpcall) (prm '!= (V x) (V (K #f)))] + [(forcall) (prm '!= (V x) (V (K #f)))] [else (error 'cogen-P "invalid pred expr ~s" x)])) (define (E x) (record-case x + [(constant) (nop)] + [(var) (nop)] + [(primref) (nop)] + [(code-loc) (nop)] + [(closure) (nop)] [(bind lhs* rhs* body) (make-bind lhs* (map V rhs*) (E body))] [(conditional e0 e1 e2) @@ -468,7 +494,8 @@ [else (error 'specify-rep "invalid program ~s" x)])) (define (specify-representation x) - (Program x)) + (let ([x (Program x)]) + x))