* added a $set-symbol-function! primitive.
This commit is contained in:
Abdulaziz Ghuloum
parent
d99c22e8c4
commit
87d8d5a5dd
|
|
@ -3012,3 +3012,374 @@ Words allocated: 0
|
|||
Words reclaimed: 0
|
||||
Elapsed time...: 1801 ms (User: 1800 ms; System: 1 ms)
|
||||
Elapsed GC time: 0 ms (CPU: 0 in 0 collections.)
|
||||
|
||||
****************************
|
||||
Benchmarking Larceny-r6rs on Thu Feb 22 23:24:03 EST 2007 under Darwin 10-231-84-55.dhcp-bl.indiana.edu 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...: 1798 ms (User: 1798 ms; System: 0 ms)
|
||||
Elapsed GC time: 0 ms (CPU: 0 in 0 collections.)
|
||||
|
||||
****************************
|
||||
Benchmarking Larceny-r6rs on Fri Feb 23 00:12:56 EST 2007 under Darwin 10-231-84-55.dhcp-bl.indiana.edu 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
|
||||
|
||||
Testing fib under Larceny-r6rs
|
||||
Compiling...
|
||||
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||
|
||||
|
||||
>
|
||||
>
|
||||
Running...
|
||||
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||
|
||||
|
||||
>
|
||||
Words allocated: 0
|
||||
Words reclaimed: 0
|
||||
Elapsed time...: 1778 ms (User: 1777 ms; System: 1 ms)
|
||||
Elapsed GC time: 0 ms (CPU: 0 in 0 collections.)
|
||||
|
||||
****************************
|
||||
Benchmarking Larceny-r6rs on Fri Feb 23 00:27:25 EST 2007 under Darwin 10-231-84-55.dhcp-bl.indiana.edu 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...: 1792 ms (User: 1787 ms; System: 3 ms)
|
||||
Elapsed GC time: 0 ms (CPU: 0 in 0 collections.)
|
||||
|
||||
****************************
|
||||
Benchmarking Larceny-r6rs on Fri Feb 23 00:28:15 EST 2007 under Darwin 10-231-84-55.dhcp-bl.indiana.edu 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
|
||||
|
||||
Testing peval under Larceny-r6rs
|
||||
Compiling...
|
||||
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||
|
||||
|
||||
>
|
||||
>
|
||||
Running...
|
||||
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||
|
||||
|
||||
>
|
||||
Words allocated: 34340444
|
||||
Words reclaimed: 0
|
||||
Elapsed time...: 1255 ms (User: 1248 ms; System: 6 ms)
|
||||
Elapsed GC time: 59 ms (CPU: 56 in 131 collections.)
|
||||
|
||||
****************************
|
||||
Benchmarking Larceny-r6rs on Fri Feb 23 00:30:10 EST 2007 under Darwin 10-231-84-55.dhcp-bl.indiana.edu 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
|
||||
|
||||
Testing peval under Larceny-r6rs
|
||||
Compiling...
|
||||
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||
|
||||
|
||||
>
|
||||
>
|
||||
Running...
|
||||
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||
|
||||
|
||||
>
|
||||
Words allocated: 34340444
|
||||
Words reclaimed: 0
|
||||
Elapsed time...: 1255 ms (User: 1248 ms; System: 7 ms)
|
||||
Elapsed GC time: 65 ms (CPU: 63 in 131 collections.)
|
||||
|
||||
****************************
|
||||
Benchmarking Larceny-r6rs on Fri Feb 23 00:30:30 EST 2007 under Darwin 10-231-84-55.dhcp-bl.indiana.edu 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...: 6575 ms (User: 6506 ms; System: 69 ms)
|
||||
Elapsed GC time: 293 ms (CPU: 282 in 385 collections.)
|
||||
|
||||
****************************
|
||||
Benchmarking Larceny-r6rs on Fri Feb 23 00:31:10 EST 2007 under Darwin 10-231-84-55.dhcp-bl.indiana.edu 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...: 1451 ms (User: 1435 ms; System: 11 ms)
|
||||
Elapsed GC time: 78 ms (CPU: 71 in 86 collections.)
|
||||
|
||||
****************************
|
||||
Benchmarking Larceny-r6rs on Fri Feb 23 00:31:41 EST 2007 under Darwin 10-231-84-55.dhcp-bl.indiana.edu 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...: 2874 ms (User: 2853 ms; System: 11 ms)
|
||||
Elapsed GC time: 168 ms (CPU: 171 in 460 collections.)
|
||||
|
||||
****************************
|
||||
Benchmarking Larceny-r6rs on Fri Feb 23 00:32:02 EST 2007 under Darwin 10-231-84-55.dhcp-bl.indiana.edu 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
|
||||
|
||||
Testing slatex under Larceny-r6rs
|
||||
Compiling...
|
||||
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||
|
||||
|
||||
>
|
||||
>
|
||||
Running...
|
||||
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||
|
||||
|
||||
>
|
||||
Words allocated: 4194150
|
||||
Words reclaimed: 0
|
||||
Elapsed time...: 1983 ms (User: 541 ms; System: 828 ms)
|
||||
Elapsed GC time: 7 ms (CPU: 11 in 16 collections.)
|
||||
|
||||
****************************
|
||||
Benchmarking Larceny-r6rs on Fri Feb 23 00:32:56 EST 2007 under Darwin 10-231-84-55.dhcp-bl.indiana.edu 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...: 1901 ms (User: 1890 ms; System: 10 ms)
|
||||
Elapsed GC time: 379 ms (CPU: 332 in 931 collections.)
|
||||
|
||||
****************************
|
||||
Benchmarking Larceny-r6rs on Fri Feb 23 00:33:16 EST 2007 under Darwin 10-231-84-55.dhcp-bl.indiana.edu 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...: 4300 ms (User: 3756 ms; System: 543 ms)
|
||||
Elapsed GC time: 2469 ms (CPU: 2470 in 768 collections.)
|
||||
|
||||
****************************
|
||||
Benchmarking Larceny-r6rs on Fri Feb 23 00:35:05 EST 2007 under Darwin 10-231-84-55.dhcp-bl.indiana.edu 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 takl 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...: 907 ms (User: 907 ms; System: 0 ms)
|
||||
Elapsed GC time: 0 ms (CPU: 0 in 0 collections.)
|
||||
|
||||
****************************
|
||||
Benchmarking Larceny-r6rs on Fri Feb 23 12:15:53 EST 2007 under Darwin adsl-75-19-179-70.dsl.bltnin.sbcglobal.net 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...: 4296 ms (User: 3755 ms; System: 540 ms)
|
||||
Elapsed GC time: 2471 ms (CPU: 2477 in 768 collections.)
|
||||
|
||||
****************************
|
||||
Benchmarking Larceny-r6rs on Fri Feb 23 12:17:01 EST 2007 under Darwin adsl-75-19-179-70.dsl.bltnin.sbcglobal.net 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...: 1594 ms (User: 1583 ms; System: 11 ms)
|
||||
Elapsed GC time: 97 ms (CPU: 90 in 272 collections.)
|
||||
|
||||
****************************
|
||||
Benchmarking Larceny-r6rs on Fri Feb 23 13:00:00 EST 2007 under Darwin adsl-75-19-179-70.dsl.bltnin.sbcglobal.net 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...: 1685 ms (User: 1602 ms; System: 82 ms)
|
||||
Elapsed GC time: 432 ms (CPU: 420 in 194 collections.)
|
||||
|
||||
****************************
|
||||
Benchmarking Larceny-r6rs on Fri Feb 23 13:00:24 EST 2007 under Darwin adsl-75-19-179-70.dsl.bltnin.sbcglobal.net 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...: 1318 ms (User: 1309 ms; System: 9 ms)
|
||||
Elapsed GC time: 44 ms (CPU: 41 in 63 collections.)
|
||||
|
||||
****************************
|
||||
Benchmarking Larceny-r6rs on Fri Feb 23 13:02:27 EST 2007 under Darwin adsl-75-19-179-70.dsl.bltnin.sbcglobal.net 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...: 1846 ms (User: 1589 ms; System: 254 ms)
|
||||
Elapsed GC time: 1145 ms (CPU: 1161 in 360 collections.)
|
||||
|
|
|
|||
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
|
|
@ -209,6 +209,7 @@
|
|||
[$symbol-value v]
|
||||
|
||||
[$memq pv]
|
||||
[$procedure-check v]
|
||||
|
||||
[$record vt]
|
||||
[$record/rtd? p]
|
||||
|
|
@ -1098,9 +1099,13 @@
|
|||
[(constant j)
|
||||
(if (fixnum? j)
|
||||
(tbind ([a (Value a)])
|
||||
(make-shortcut
|
||||
(make-seq
|
||||
(make-conditional
|
||||
(tag-test a fixnum-mask fixnum-tag)
|
||||
(prm op a (Value b))
|
||||
(make-primcall 'nop '())
|
||||
(make-primcall 'interrupt '()))
|
||||
(prm op a (Value b)))
|
||||
(call a (Value b))))
|
||||
(call (Value a) (Value b)))]
|
||||
[else
|
||||
|
|
@ -1179,13 +1184,17 @@
|
|||
(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)))
|
||||
pair-tag))))
|
||||
(Value
|
||||
(make-funcall (make-primref 'error)
|
||||
(list (K 'car) (K "~s is not a pair") x)))))]
|
||||
(list (K op) (K "~s is not a pair") x)))))]
|
||||
[(primitive-ref)
|
||||
(tbind ([x (Value (car arg*))])
|
||||
(prm 'mref x
|
||||
|
|
@ -1228,7 +1237,7 @@
|
|||
(K (- disp-symbol-system-value symbol-tag))
|
||||
(K unbound))
|
||||
(prm 'mset x
|
||||
(K (- disp-symbol-system-plist symbol-tag))
|
||||
(K (- disp-symbol-function symbol-tag))
|
||||
(K nil))
|
||||
x)))]
|
||||
[(list)
|
||||
|
|
@ -1807,6 +1816,19 @@
|
|||
(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*))])
|
||||
|
|
@ -1948,6 +1970,20 @@
|
|||
[($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 (error who "value prim ~a not supported" (unparse x))])]
|
||||
[(forcall op arg*)
|
||||
(make-forcall op (map Value arg*))]
|
||||
|
|
@ -2020,7 +2056,7 @@
|
|||
(cond
|
||||
[(or (constant? x) (var? x) (symbol? x)) (k x)]
|
||||
[(or (funcall? x) (primcall? x) (jmpcall? x)
|
||||
(forcall? x)
|
||||
(forcall? x) (shortcut? x)
|
||||
(conditional? x))
|
||||
(let ([t (unique-var 'tmp)])
|
||||
(do-bind (list t) (list x)
|
||||
|
|
@ -2071,13 +2107,15 @@
|
|||
[body
|
||||
(make-nframe frmt* #f
|
||||
(do-bind-frmt* frmt* frm-args
|
||||
(do-bind regt* reg-args
|
||||
(do-bind (cdr regt*) (cdr reg-args)
|
||||
;;; evaluate cpt last
|
||||
(do-bind (list (car regt*)) (list (car reg-args))
|
||||
(assign* reg-locs regt*
|
||||
(make-seq
|
||||
(make-set argc-register
|
||||
(make-constant
|
||||
(argc-convention (length rands))))
|
||||
call)))))])
|
||||
call))))))])
|
||||
(if value-dest
|
||||
(make-seq body (make-set value-dest return-value-register))
|
||||
body)))))
|
||||
|
|
@ -2237,6 +2275,8 @@
|
|||
(lambda (rands)
|
||||
(let ([a (car rands)] [b (cadr rands)])
|
||||
(make-asm-instr op a b))))]))]
|
||||
[(shortcut body handler)
|
||||
(make-shortcut (P body) (P handler))]
|
||||
[else (error who "invalid pred ~s" x)]))
|
||||
;;;
|
||||
(define (Tail env)
|
||||
|
|
@ -2494,6 +2534,8 @@
|
|||
(or (P e0) (P e1) (P e2))]
|
||||
[(asm-instr) #f]
|
||||
[(constant) #f]
|
||||
[(shortcut body handler)
|
||||
(or (P body) (P handler))]
|
||||
[else (error who "invalid pred ~s" x)]))
|
||||
(define (T x)
|
||||
(record-case x
|
||||
|
|
@ -2887,6 +2929,16 @@
|
|||
(values vsf rsf fsf nsf))]
|
||||
[(asm-instr op d s)
|
||||
(R* (list d s) vsu rsu fsu nsu)]
|
||||
[(shortcut body handler)
|
||||
(let-values ([(vsh rsh fsh nsh)
|
||||
(P handler vst rst fst nst
|
||||
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)))]
|
||||
[else (error who "invalid pred ~s" (unparse x))]))
|
||||
(define (T x)
|
||||
(record-case x
|
||||
|
|
@ -3145,6 +3197,8 @@
|
|||
(make-conditional (P e0) (P e1) (P e2))]
|
||||
[(asm-instr op d s) (make-asm-instr op (R d) (R s))]
|
||||
[(constant) x]
|
||||
[(shortcut body handler)
|
||||
(make-shortcut (P body) (P handler))]
|
||||
[else (error who "invalid pred ~s" (unparse x))]))
|
||||
(define (T x)
|
||||
(record-case x
|
||||
|
|
@ -3310,6 +3364,10 @@
|
|||
(P e0 s1 s2 (set-union s1 s2)))]
|
||||
[(asm-instr op s0 s1)
|
||||
(union (union (R s0) (R s1)) su)]
|
||||
[(shortcut body handler)
|
||||
(let ([s2 (P handler st sf su)])
|
||||
(parameterize ([exception-live-set s2])
|
||||
(P body st sf su)))]
|
||||
[else (error who "invalid pred ~s" (unparse x))]))
|
||||
(define (T x)
|
||||
(record-case x
|
||||
|
|
@ -3445,6 +3503,8 @@
|
|||
[(conditional e0 e1 e2)
|
||||
(make-conditional (P e0) (P e1) (P e2))]
|
||||
[(seq e0 e1) (make-seq (E e0) (P e1))]
|
||||
[(shortcut body handler)
|
||||
(make-shortcut (P body) (P handler))]
|
||||
[else (error who "invalid pred ~s" (unparse x))]))
|
||||
(define (T x)
|
||||
(record-case x
|
||||
|
|
@ -3628,6 +3688,9 @@
|
|||
(E (make-asm-instr 'move u b))
|
||||
(make-asm-instr op a u)))]
|
||||
[else x])]
|
||||
[(shortcut body handler)
|
||||
(let ([body (P body)])
|
||||
(make-shortcut body (P handler)))]
|
||||
[else (error who "invalid pred ~s" (unparse x))]))
|
||||
(define (T x)
|
||||
(record-case x
|
||||
|
|
@ -3737,16 +3800,30 @@
|
|||
(if (eq? x ecx)
|
||||
'%cl
|
||||
(error who "invalid R/cl ~s" x))]))
|
||||
(define (interrupt? x)
|
||||
(record-case x
|
||||
[(primcall op args) (eq? op 'interrupt)]
|
||||
[else #f]))
|
||||
;;; flatten effect
|
||||
(define (E x ac)
|
||||
(record-case x
|
||||
[(seq e0 e1) (E e0 (E e1 ac))]
|
||||
[(conditional e0 e1 e2)
|
||||
(cond
|
||||
[(interrupt? e1)
|
||||
(let ([L (or (exception-label)
|
||||
(error who "no exception label"))])
|
||||
(P e0 L #f (E e2 ac)))]
|
||||
[(interrupt? e2)
|
||||
(let ([L (or (exception-label)
|
||||
(error who "no exception label"))])
|
||||
(P e0 #f L (E e1 ac)))]
|
||||
[else
|
||||
(let ([lf (unique-label)] [le (unique-label)])
|
||||
(P e0 #f lf
|
||||
(E e1
|
||||
(list* `(jmp ,le) lf
|
||||
(E e2 (cons le ac))))))]
|
||||
(E e2 (cons le ac))))))])]
|
||||
[(ntcall target value args mask size)
|
||||
(let ([LCALL (unique-label)])
|
||||
(define (rp-label value)
|
||||
|
|
@ -3835,12 +3912,21 @@
|
|||
(cons `(jmp ,l) ac))]
|
||||
[else (error who "invalid effect ~s" (unparse x))])]
|
||||
[(shortcut body handler)
|
||||
(let ([L (unique-label)] [L2 (unique-label)])
|
||||
(let ([ac (cons L (E handler (cons L2 ac)))])
|
||||
(let ([L (unique-interrupt-label)] [L2 (unique-label)])
|
||||
(let ([hand (cons L (E handler `((jmp ,L2))))])
|
||||
(let ([tc (exceptions-conc)])
|
||||
(set-cdr! tc (append hand (cdr tc)))))
|
||||
(parameterize ([exception-label L])
|
||||
(E body (cons `(jmp ,L2) ac)))))]
|
||||
(E body (cons L2 ac))))]
|
||||
;[(shortcut body handler)
|
||||
; (let ([L (unique-label)] [L2 (unique-label)])
|
||||
; (let ([ac (cons L (E handler (cons L2 ac)))])
|
||||
; (parameterize ([exception-label L])
|
||||
; (E body (cons `(jmp ,L2) ac)))))]
|
||||
[else (error who "invalid effect ~s" (unparse x))]))
|
||||
;;;
|
||||
(define (unique-interrupt-label)
|
||||
(label (gensym "ERROR")))
|
||||
(define (unique-label)
|
||||
(label (gensym)))
|
||||
;;;
|
||||
|
|
@ -3915,6 +4001,14 @@
|
|||
[lf
|
||||
(cmp (notop op) a0 a1 lf ac)]
|
||||
[else ac]))]
|
||||
[(shortcut body handler)
|
||||
(let ([L (unique-interrupt-label)] [lj (unique-label)])
|
||||
(let ([ac (if (and lt lf) ac (cons lj ac))])
|
||||
(let ([hand (cons L (P handler (or lt lj) (or lf lj) '()))])
|
||||
(let ([tc (exceptions-conc)])
|
||||
(set-cdr! tc (append hand (cdr tc)))))
|
||||
(parameterize ([exception-label L])
|
||||
(P body lt lf ac))))]
|
||||
[else (error who "invalid pred ~s" x)]))
|
||||
;;;
|
||||
(define (T x ac)
|
||||
|
|
@ -3933,10 +4027,12 @@
|
|||
(cons `(jmp (label ,(code-loc-label (car rands)))) ac)]
|
||||
[else (error who "invalid tail ~s" x)])]
|
||||
[(shortcut body handler)
|
||||
(let ([L (unique-label)])
|
||||
(let ([ac (cons L (T handler ac))])
|
||||
(let ([L (unique-interrupt-label)])
|
||||
(let ([hand (cons L (T handler '()))])
|
||||
(let ([tc (exceptions-conc)])
|
||||
(set-cdr! tc (append hand (cdr tc)))))
|
||||
(parameterize ([exception-label L])
|
||||
(T body ac))))]
|
||||
(T body ac)))]
|
||||
[else (error who "invalid tail ~s" x)]))
|
||||
(define exception-label (make-parameter #f))
|
||||
;;;
|
||||
|
|
@ -4029,20 +4125,25 @@
|
|||
[(clambda L case* free*)
|
||||
(list* (length free*)
|
||||
(label L)
|
||||
(let ([ac (list '(nop))])
|
||||
(parameterize ([exceptions-conc ac])
|
||||
(let f ([case* case*])
|
||||
(cond
|
||||
[(null? case*) (invalid-args-error)]
|
||||
[(null? case*)
|
||||
(cons `(jmp (label ,SL_invalid_args)) ac)]
|
||||
[else
|
||||
(ClambdaCase (car case*) (f (cdr case*)))])))]))
|
||||
(define (invalid-args-error)
|
||||
`((jmp (label ,SL_invalid_args))))
|
||||
(ClambdaCase (car case*) (f (cdr case*)))])))))]))
|
||||
;;;
|
||||
(define exceptions-conc (make-parameter #f))
|
||||
;;;
|
||||
(define (Program x)
|
||||
(record-case x
|
||||
[(codes code* body)
|
||||
(cons (list* 0
|
||||
(label (gensym))
|
||||
(T body '()))
|
||||
(let ([ac (list '(nop))])
|
||||
(parameterize ([exceptions-conc ac])
|
||||
(T body ac))))
|
||||
(map Clambda code*))]))
|
||||
;;;
|
||||
;;; (print-code x)
|
||||
|
|
|
|||
|
|
@ -130,6 +130,7 @@
|
|||
[$symbol-string 1 value]
|
||||
[$symbol-unique-string 1 value]
|
||||
[$set-symbol-value! 2 effect]
|
||||
[$set-symbol-function! 2 effect]
|
||||
[$set-symbol-string! 2 effect]
|
||||
[$set-symbol-unique-string! 2 effect]
|
||||
[$symbol-plist 1 value]
|
||||
|
|
@ -1608,6 +1609,10 @@
|
|||
[else (error who "invalid expression ~s" (unparse x))]))
|
||||
(Expr x))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(define (optimize-for-direct-jumps x)
|
||||
(define who 'optimize-for-direct-jumps)
|
||||
(define (init-var x)
|
||||
|
|
@ -1697,6 +1702,59 @@
|
|||
(Expr x))
|
||||
|
||||
|
||||
(define (insert-funcall-error-checks x)
|
||||
(define who 'insert-funcall-error-checks)
|
||||
(define called-symbols '())
|
||||
(define (R x)
|
||||
(record-case x
|
||||
[(constant p)
|
||||
(if (procedure? p)
|
||||
x
|
||||
(make-primcall '$procedure-check (list x)))]
|
||||
[(primref) x]
|
||||
[(clambda g cls* ?) (E x)]
|
||||
[else (make-primcall '$procedure-check (list (E x)))]))
|
||||
(define (E x)
|
||||
(record-case x
|
||||
[(constant) x]
|
||||
[(var) x]
|
||||
[(primref) x]
|
||||
[(bind lhs* rhs* body)
|
||||
(make-bind lhs* (map E rhs*) (E body))]
|
||||
[(fix lhs* rhs* body)
|
||||
(make-fix lhs* (map E rhs*) (E body))]
|
||||
[(conditional test conseq altern)
|
||||
(make-conditional (E test) (E conseq) (E altern))]
|
||||
[(seq e0 e1) (make-seq (E e0) (E e1))]
|
||||
[(clambda g cls* ?)
|
||||
(make-clambda g
|
||||
(map (lambda (cls)
|
||||
(record-case cls
|
||||
[(clambda-case info body)
|
||||
(make-clambda-case info (E body))]))
|
||||
cls*)
|
||||
?)]
|
||||
[(primcall op rand*)
|
||||
(make-primcall op (map E rand*))]
|
||||
[(forcall op rand*)
|
||||
(make-forcall op (map E rand*))]
|
||||
[(funcall rator rand*)
|
||||
(make-funcall (R rator) (map E rand*))]
|
||||
[(jmpcall label rator rand*)
|
||||
(make-jmpcall label (E rator) (map E rand*))]
|
||||
[(mvcall p c) (make-mvcall (E p) (E c))]
|
||||
[else (error who "invalid expression ~s" (unparse x))]))
|
||||
(let ([x (E x)])
|
||||
(if (null? called-symbols)
|
||||
x
|
||||
(make-seq
|
||||
(make-funcall
|
||||
(make-primref 'for-each)
|
||||
(list (make-primref '$reset-symbol-function!)
|
||||
(make-constant called-symbols)))
|
||||
x))))
|
||||
|
||||
|
||||
(define (convert-closures prog)
|
||||
(define who 'convert-closures)
|
||||
(define (Expr* x*)
|
||||
|
|
@ -1790,6 +1848,12 @@
|
|||
free (unparse prog)))
|
||||
prog))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(define (optimize-closures/lift-codes x)
|
||||
(define who 'optimize-closures/lift-codes)
|
||||
(define all-codes '())
|
||||
|
|
@ -1936,7 +2000,6 @@
|
|||
(make-codes all-codes x)))
|
||||
|
||||
|
||||
|
||||
(include "libcogen1.ss")
|
||||
|
||||
|
||||
|
|
@ -2057,7 +2120,7 @@
|
|||
[($symbol-string $symbol-unique-string)
|
||||
(andmap (check op symbol?) rand*)]
|
||||
[($constant-ref $set-constant! $intern $pcb-set! $pcb-ref $make-symbol
|
||||
$symbol-value $set-symbol-value! $symbol-plist $set-symbol-plist!
|
||||
$symbol-value $set-symbol-value! $set-symbol-function! $symbol-plist $set-symbol-plist!
|
||||
$set-symbol-system-value! $set-symbol-system-value!
|
||||
$set-symbol-unique-string!
|
||||
$set-symbol-string!
|
||||
|
|
@ -3036,7 +3099,7 @@
|
|||
(define disp-symbol-value 8)
|
||||
(define disp-symbol-plist 12)
|
||||
(define disp-symbol-system-value 16)
|
||||
(define disp-symbol-system-plist 20)
|
||||
(define disp-symbol-function 20)
|
||||
(define symbol-size 24)
|
||||
(define vector-tag 5)
|
||||
(define vector-mask 7)
|
||||
|
|
@ -3932,7 +3995,7 @@
|
|||
(movl (int unbound) (mem disp-symbol-value apr))
|
||||
(movl (int nil) (mem disp-symbol-plist apr))
|
||||
(movl (int unbound) (mem disp-symbol-system-value apr))
|
||||
(movl (int nil) (mem disp-symbol-system-plist apr))
|
||||
(movl (int nil) (mem disp-symbol-function apr))
|
||||
(movl apr eax)
|
||||
(addl (int symbol-tag) eax)
|
||||
(addl (int (align symbol-size)) apr)
|
||||
|
|
@ -4055,7 +4118,7 @@
|
|||
(list* (addl (int (fx- vector-tag disp-code-data)) eax)
|
||||
ac))]
|
||||
[($set-car! $set-cdr! $vector-set! $string-set! $exit
|
||||
$set-symbol-value! $set-symbol-plist!
|
||||
$set-symbol-value! $set-symbol-function! $set-symbol-plist!
|
||||
$code-set! primitive-set!
|
||||
$set-code-object! $set-code-object+offset! $set-code-object+offset/rel!
|
||||
$record-set!
|
||||
|
|
@ -4219,6 +4282,17 @@
|
|||
(addl (pcb-ref 'dirty-vector) eax)
|
||||
(movl (int dirty-word) (mem 0 eax))
|
||||
ac)]
|
||||
[($set-symbol-function!)
|
||||
(list* (movl (Simple (car arg*)) eax)
|
||||
(movl (Simple (cadr arg*)) ebx)
|
||||
(movl ebx (mem (fx- disp-symbol-function symbol-tag) eax))
|
||||
;;; record side effect
|
||||
(addl (int (fx- disp-symbol-function symbol-tag)) eax)
|
||||
(shrl (int pageshift) eax)
|
||||
(sall (int wordshift) eax)
|
||||
(addl (pcb-ref 'dirty-vector) eax)
|
||||
(movl (int dirty-word) (mem 0 eax))
|
||||
ac)]
|
||||
[(primitive-set!)
|
||||
(list* (movl (Simple (car arg*)) eax)
|
||||
(movl (Simple (cadr arg*)) ebx)
|
||||
|
|
@ -5159,6 +5233,7 @@
|
|||
[p (copy-propagate p)]
|
||||
[p (rewrite-assignments p)]
|
||||
[p (optimize-for-direct-jumps p)]
|
||||
[p (insert-funcall-error-checks p)]
|
||||
[p (convert-closures p)]
|
||||
[p (optimize-closures/lift-codes p)])
|
||||
(let ([ls* (alt-cogen p)])
|
||||
|
|
|
|||
|
|
@ -340,7 +340,12 @@ reference-implementation:
|
|||
(lambda (x v)
|
||||
(unless (symbol? x)
|
||||
(error 'set-top-level-value! "~s is not a symbol" x))
|
||||
($set-symbol-value! x v)))
|
||||
($set-symbol-value! x v)
|
||||
(if (procedure? v)
|
||||
($set-symbol-function! x v)
|
||||
($set-symbol-function! x
|
||||
(lambda args
|
||||
(error 'apply "~s is not a procedure" v))))))
|
||||
|
||||
(primitive-set! 'symbol? (lambda (x) (symbol? x)))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,14 @@
|
|||
|
||||
|
||||
(primitive-set! '$reset-symbol-function!
|
||||
(lambda (x)
|
||||
(let ([v ($symbol-value x)])
|
||||
(if (procedure? v)
|
||||
($set-symbol-function! x v)
|
||||
($set-symbol-function! x
|
||||
(lambda args
|
||||
(error 'apply "~s is not a procedure" v)))))))
|
||||
|
||||
(primitive-set! 'make-parameter
|
||||
(case-lambda
|
||||
[(x)
|
||||
|
|
|
|||
|
|
@ -116,7 +116,7 @@
|
|||
$make-string $string-ref $string-set! $string-length $string
|
||||
$symbol-string $symbol-unique-string $symbol-value
|
||||
$set-symbol-string! $set-symbol-unique-string!
|
||||
$set-symbol-value! $make-symbol $set-symbol-plist!
|
||||
$set-symbol-value! $set-symbol-function! $make-symbol $set-symbol-plist!
|
||||
$symbol-plist $sc-put-cte $record? $record/rtd? $record-set!
|
||||
$record-ref $record-rtd $make-record $record $base-rtd $code?
|
||||
$code-reloc-vector $code-freevars $code-size $code-ref
|
||||
|
|
|
|||
Loading…
Reference in New Issue