conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* added a $set-symbol-function! primitive.

This commit is contained in:
Abdulaziz Ghuloum 2007-02-24 15:42:57 -05:00
parent d99c22e8c4
commit 87d8d5a5dd
7 changed files with 607 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

371
benchmarks/results.Larceny-r6rs
View File

@ -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
View File

Binary file not shown.

179
src/libaltcogen.ss
View File

@ -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-conditional
(tag-test a fixnum-mask fixnum-tag)
(prm op a (Value b))
(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
@ -1179,13 +1184,17 @@
(prm 'mref x (K (- disp-cdr pair-tag))))]
[(car cdr)
(tbind ([x (Value (car arg*))])
(make-conditional
(tag-test x pair-mask pair-tag)
(prm 'mref x (K (- (if (eq? op 'car) disp-car disp-cdr)
pair-tag)))
(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 '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
(assign* reg-locs regt*
(make-seq
(make-set argc-register
(make-constant
(argc-convention (length rands))))
call)))))])
(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))))))])
(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)
(let ([lf (unique-label)] [le (unique-label)])
(P e0 #f lf
(E e1
(list* `(jmp ,le) lf
(E e2 (cons le ac))))))]
(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))))))])]
[(ntcall target value args mask size)
(let ([LCALL (unique-label)])
(define (rp-label value)
@ -3834,13 +3911,22 @@
(error who "no exception label"))])
(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)))])
(parameterize ([exception-label L])
(E body (cons `(jmp ,L2) ac)))))]
[(shortcut body handler)
(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 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))])
(parameterize ([exception-label L])
(T body 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)))]
[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 f ([case* case*])
(cond
[(null? case*) (invalid-args-error)]
[else
(ClambdaCase (car case*) (f (cdr case*)))])))]))
(define (invalid-args-error)
`((jmp (label ,SL_invalid_args))))
(let ([ac (list '(nop))])
(parameterize ([exceptions-conc ac])
(let f ([case* case*])
(cond
[(null? case*)
(cons `(jmp (label ,SL_invalid_args)) ac)]
[else
(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)

85
src/libcompile.ss
View File

@ -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)])

7
src/libcore.ss
View File

@ -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)))

9
src/libhandlers.ss
View File

@ -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)

2
src/makefile.ss
View File

@ -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