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

* The shortcut form is now two parts: a body and a handler. The 

evaluation of the body can jump to the handler at any point during
  evaluation by means of using the interrupt primitive or by
  overflow.
This commit is contained in:
Abdulaziz Ghuloum 2007-02-22 23:02:50 -05:00
parent 819a3ca1c1
commit d99c22e8c4
4 changed files with 125 additions and 103 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
benchmarks/results.Larceny-r6rs
View File

@ -2992,3 +2992,23 @@ Words allocated: 7834358
Words reclaimed: 0 Words reclaimed: 0
Elapsed time...: 420 ms (User: 399 ms; System: 21 ms) Elapsed time...: 420 ms (User: 399 ms; System: 21 ms)
Elapsed GC time: 36 ms (CPU: 37 in 30 collections.) Elapsed GC time: 36 ms (CPU: 37 in 30 collections.)
****************************
Benchmarking Larceny-r6rs on Thu Feb 22 22:55:29 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...: 1801 ms (User: 1800 ms; System: 1 ms)
Elapsed GC time: 0 ms (CPU: 0 in 0 collections.)

BIN
src/ikarus.boot
View File

Binary file not shown.

203
src/libaltcogen.ss
View File

@ -1538,9 +1538,13 @@
[(constant i) [(constant i)
(if (fixnum? i) (if (fixnum? i)
(tbind ([b (Value b)]) (tbind ([b (Value b)])
(make-shortcut^ (make-shortcut
(tag-test b fixnum-mask fixnum-tag) (make-seq
(prm 'int+/overflow (Value a) b) (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 '+)) (make-funcall (Value (make-primref '+))
(list (Value a) b)))) (list (Value a) b))))
(make-funcall (Value (make-primref '+)) (make-funcall (Value (make-primref '+))
@ -1550,19 +1554,27 @@
[(constant i) [(constant i)
(if (fixnum? i) (if (fixnum? i)
(tbind ([a (Value a)]) (tbind ([a (Value a)])
(make-shortcut^ (make-shortcut
(tag-test a fixnum-mask fixnum-tag) (make-seq
(prm 'int+/overflow a (Value b)) (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 '+)) (make-funcall (Value (make-primref '+))
(list a (Value b))))) (list a (Value b)))))
(make-funcall (Value (make-primref '+)) (make-funcall (Value (make-primref '+))
(list a (Value b))))] (list a (Value b))))]
[else [else
(tbind ([a (Value a)] (tbind ([a (Value a)]
[b (Value b)]) [b (Value b)])
(make-shortcut^ (make-shortcut
(tag-test (prm 'logor a b) fixnum-mask fixnum-tag) (make-seq
(prm 'int+/overflow a b) (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 '+)) (make-funcall (Value (make-primref '+))
(list a b))))])])) (list a b))))])]))
(cond (cond
@ -1591,9 +1603,13 @@
[(constant i) [(constant i)
(if (fixnum? i) (if (fixnum? i)
(tbind ([b (Value b)]) (tbind ([b (Value b)])
(make-shortcut^ (make-shortcut
(tag-test b fixnum-mask fixnum-tag) (make-seq
(prm 'int-/overflow (Value a) b) (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 '-)) (make-funcall (Value (make-primref '-))
(list (Value a) b)))) (list (Value a) b))))
(make-funcall (Value (make-primref '-)) (make-funcall (Value (make-primref '-))
@ -1603,19 +1619,27 @@
[(constant i) [(constant i)
(if (fixnum? i) (if (fixnum? i)
(tbind ([a (Value a)]) (tbind ([a (Value a)])
(make-shortcut^ (make-shortcut
(tag-test a fixnum-mask fixnum-tag) (make-seq
(prm 'int-/overflow a (Value b)) (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 '-)) (make-funcall (Value (make-primref '-))
(list a (Value b))))) (list a (Value b)))))
(make-funcall (Value (make-primref '-)) (make-funcall (Value (make-primref '-))
(list a (Value b))))] (list a (Value b))))]
[else [else
(tbind ([a (Value a)] (tbind ([a (Value a)]
[b (Value b)]) [b (Value b)])
(make-shortcut^ (make-shortcut
(tag-test (prm 'logor a b) fixnum-mask fixnum-tag) (make-seq
(prm 'int-/overflow a b) (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 '-)) (make-funcall (Value (make-primref '-))
(list a b))))])])) (list a b))))])]))
(cond (cond
@ -2144,10 +2168,10 @@
(handle-nontail-call (handle-nontail-call
(make-constant (make-foreign-label op)) (make-constant (make-foreign-label op))
rands d op)] rands d op)]
[(shortcut^ test body handler) [(shortcut body handler)
(make-shortcut^ (P test) (make-shortcut
(V d body) (V d body)
(V d handler))] (V d handler))]
[else [else
(if (symbol? x) (if (symbol? x)
(make-set d x) (make-set d x)
@ -2181,7 +2205,7 @@
(make-asm-instr op (make-asm-instr op
(make-disp (car s*) (cadr s*)) (make-disp (car s*) (cadr s*))
(caddr s*))))] (caddr s*))))]
[(nop) x] [(nop interrupt) x]
[else (error 'impose-effect "invalid instr ~s" x)])] [else (error 'impose-effect "invalid instr ~s" x)])]
[(funcall rator rands) [(funcall rator rands)
(handle-nontail-call rator rands #f #f)] (handle-nontail-call rator rands #f #f)]
@ -2290,8 +2314,8 @@
[(jmpcall label rator rands) [(jmpcall label rator rands)
(handle-tail-call (make-code-loc label) rator rands)] (handle-tail-call (make-code-loc label) rator rands)]
[(forcall) (VT x)] [(forcall) (VT x)]
[(shortcut^ test body handler) [(shortcut body handler)
(make-shortcut^ (P test) (Tail body) (Tail handler))] (make-shortcut (Tail body) (Tail handler))]
[else (error who "invalid tail ~s" x)])) [else (error who "invalid tail ~s" x)]))
Tail) Tail)
;;; ;;;
@ -2458,10 +2482,10 @@
[(asm-instr) #f] [(asm-instr) #f]
[(primcall op args) [(primcall op args)
(case op (case op
[(nop) #f] [(interrupt nop) #f]
[else (error who "invalid effect ~s" (unparse x))])] [else (error who "invalid effect ~s" (unparse x))])]
[(shortcut^ test body handler) [(shortcut body handler)
(or (P test) (E body) (E handler))] (or (E body) (E handler))]
[else (error who "invalid effect ~s" x)])) [else (error who "invalid effect ~s" x)]))
(define (P x) (define (P x)
(record-case x (record-case x
@ -2478,8 +2502,8 @@
[(conditional e0 e1 e2) [(conditional e0 e1 e2)
(or (P e0) (T e1) (T e2))] (or (P e0) (T e1) (T e2))]
[(primcall) #f] [(primcall) #f]
[(shortcut^ test body handler) [(shortcut body handler)
(or (P test) (T body) (T handler))] (or (T body) (T handler))]
[else (error who "invalid tail ~s" x)])) [else (error who "invalid tail ~s" x)]))
(T x)) (T x))
;;; ;;;
@ -2816,20 +2840,20 @@
[(primcall op args) [(primcall op args)
(case op (case op
[(nop) (values vs rs fs ns)] [(nop) (values vs rs fs ns)]
[(interrupt)
(let ([v (exception-live-set)])
(unless (vector? v)
(error who "unbound exception"))
(values (vector-ref v 0)
(vector-ref v 1)
(vector-ref v 2)
(vector-ref v 3)))]
[else (error who "invalid effect op ~s" op)])] [else (error who "invalid effect op ~s" op)])]
[(shortcut^ pred body handler) [(shortcut body handler)
(let-values ([(vsh rsh fsh nsh) (E handler vs rs fs ns)]) (let-values ([(vsh rsh fsh nsh) (E handler vs rs fs ns)])
(let-values ([(vsb rsb fsb nsb) (parameterize ([exception-live-set
(parameterize ([exception-live-set (vector vsh rsh fsh nsh)])
(vector vsh rsh fsh nsh)]) (E body vs rs fs ns)))]
(E body vs rs fs ns))])
(P pred
vsb rsb fsb nsb
vsh rsh fsh nsh
(union-vars vsb vsh)
(union-regs rsb rsh)
(union-frms fsb fsh)
(union-nfvs nsb nsh))))]
[else (error who "invalid effect ~s" (unparse x))])) [else (error who "invalid effect ~s" (unparse x))]))
(define (P x vst rst fst nst (define (P x vst rst fst nst
vsf rsf fsf nsf vsf rsf fsf nsf
@ -2887,19 +2911,11 @@
(empty-frm-set) (empty-frm-set)
(empty-nfv-set))] (empty-nfv-set))]
[else (error who "invalid tail op ~s" x)])] [else (error who "invalid tail op ~s" x)])]
[(shortcut^ pred body handler) [(shortcut body handler)
(let-values ([(vsh rsh fsh nsh) (T handler)]) (let-values ([(vsh rsh fsh nsh) (T handler)])
(let-values ([(vsb rsb fsb nsb) (parameterize ([exception-live-set
(parameterize ([exception-live-set (vector vsh rsh fsh nsh)])
(vector vsh rsh fsh nsh)]) (T body)))]
(T body))])
(P pred
vsb rsb fsb nsb
vsh rsh fsh nsh
(union-vars vsb vsh)
(union-regs rsb rsh)
(union-frms fsb fsh)
(union-nfvs nsb nsh))))]
[else (error who "invalid tail ~s" x)])) [else (error who "invalid tail ~s" x)]))
(define exception-live-set (define exception-live-set
(make-parameter #f)) (make-parameter #f))
@ -3115,10 +3131,10 @@
(NFE (fxsub1 i) (make-mask (fxsub1 i)) body)))] (NFE (fxsub1 i) (make-mask (fxsub1 i)) body)))]
[(primcall op args) [(primcall op args)
(case op (case op
[(nop) x] [(nop interrupt) x]
[else (error who "invalid effect prim ~s" op)])] [else (error who "invalid effect prim ~s" op)])]
[(shortcut^ test body handler) [(shortcut body handler)
(make-shortcut^ (P test) (E body) (E handler))] (make-shortcut (E body) (E handler))]
[else (error who "invalid effect ~s" (unparse x))])) [else (error who "invalid effect ~s" (unparse x))]))
(define (P x) (define (P x)
(record-case x (record-case x
@ -3138,8 +3154,8 @@
[(conditional e0 e1 e2) [(conditional e0 e1 e2)
(make-conditional (P e0) (T e1) (T e2))] (make-conditional (P e0) (T e1) (T e2))]
[(primcall op args) x] [(primcall op args) x]
[(shortcut^ test body handler) [(shortcut body handler)
(make-shortcut^ (P test) (T body) (T handler))] (make-shortcut (T body) (T handler))]
[else (error who "invalid tail ~s" (unparse x))])) [else (error who "invalid tail ~s" (unparse x))]))
(T x)) (T x))
;;; ;;;
@ -3276,12 +3292,13 @@
[(primcall op arg*) [(primcall op arg*)
(case op (case op
[(nop) s] [(nop) s]
[(interrupt)
(or (exception-live-set) (error who "uninitialized exception"))]
[else (error who "invalid effect primcall ~s" op)])] [else (error who "invalid effect primcall ~s" op)])]
[(shortcut^ test body handler) [(shortcut body handler)
(let ([s2 (E handler s)]) (let ([s2 (E handler s)])
(let ([s1 (parameterize ([exception-live-set s2]) (parameterize ([exception-live-set s2])
(E body s))]) (E body s)))]
(P test s1 s2 (set-union s1 s2))))]
[else (error who "invalid effect ~s" (unparse x))])) [else (error who "invalid effect ~s" (unparse x))]))
(define (P x st sf su) (define (P x st sf su)
(record-case x (record-case x
@ -3302,11 +3319,10 @@
[(primcall op rands) [(primcall op rands)
(R* rands)] (R* rands)]
[(seq e0 e1) (E e0 (T e1))] [(seq e0 e1) (E e0 (T e1))]
[(shortcut^ test body handler) [(shortcut body handler)
(let ([s2 (T handler)]) (let ([s2 (T handler)])
(let ([s1 (parameterize ([exception-live-set s2]) (parameterize ([exception-live-set s2])
(T body))]) (T body)))]
(P test s1 s2 (set-union s1 s2))))]
[else (error who "invalid tail ~s" (unparse x))])) [else (error who "invalid tail ~s" (unparse x))]))
(define exception-live-set (make-parameter #f)) (define exception-live-set (make-parameter #f))
(let ([s (T x)]) (let ([s (T x)])
@ -3418,8 +3434,8 @@
[(primcall op rands) [(primcall op rands)
(make-primcall op (map R rands))] (make-primcall op (map R rands))]
[(ntcall) x] [(ntcall) x]
[(shortcut^ test body handler) [(shortcut body handler)
(make-shortcut^ (P test) (E body) (E handler))] (make-shortcut (E body) (E handler))]
[else (error who "invalid effect ~s" (unparse x))])) [else (error who "invalid effect ~s" (unparse x))]))
(define (P x) (define (P x)
(record-case x (record-case x
@ -3436,8 +3452,8 @@
[(conditional e0 e1 e2) [(conditional e0 e1 e2)
(make-conditional (P e0) (T e1) (T e2))] (make-conditional (P e0) (T e1) (T e2))]
[(seq e0 e1) (make-seq (E e0) (T e1))] [(seq e0 e1) (make-seq (E e0) (T e1))]
[(shortcut^ test body handler) [(shortcut body handler)
(make-shortcut^ (P test) (T body) (T handler))] (make-shortcut (T body) (T handler))]
[else (error who "invalid tail ~s" (unparse x))])) [else (error who "invalid tail ~s" (unparse x))]))
;(print-code x) ;(print-code x)
(T x)) (T x))
@ -3582,16 +3598,12 @@
[else (error who "invalid effect ~s" op)])] [else (error who "invalid effect ~s" op)])]
[(primcall op rands) [(primcall op rands)
(case op (case op
[(nop) x] [(nop interrupt) x]
[(record-effect)
(S* rands
(lambda (s*)
(make-primcall op s*)))]
[else (error who "invalid op in ~s" (unparse x))])] [else (error who "invalid op in ~s" (unparse x))])]
[(ntcall) x] [(ntcall) x]
[(shortcut^ test body handler) [(shortcut body handler)
(let ([body (E body)]) (let ([body (E body)])
(make-shortcut^ (P test) body (E handler)))] (make-shortcut body (E handler)))]
[else (error who "invalid effect ~s" (unparse x))])) [else (error who "invalid effect ~s" (unparse x))]))
(define (P x) (define (P x)
(record-case x (record-case x
@ -3623,8 +3635,8 @@
[(conditional e0 e1 e2) [(conditional e0 e1 e2)
(make-conditional (P e0) (T e1) (T e2))] (make-conditional (P e0) (T e1) (T e2))]
[(seq e0 e1) (make-seq (E e0) (T e1))] [(seq e0 e1) (make-seq (E e0) (T e1))]
[(shortcut^ test body handler) [(shortcut body handler)
(make-shortcut^ (P test) (T body) (T handler))] (make-shortcut (T body) (T handler))]
[else (error who "invalid tail ~s" (unparse x))])) [else (error who "invalid tail ~s" (unparse x))]))
(let ([x (T x)]) (let ([x (T x)])
(values un* x))) (values un* x)))
@ -3817,22 +3829,16 @@
[(primcall op rands) [(primcall op rands)
(case op (case op
[(nop) ac] [(nop) ac]
[(record-effect) [(interrupt)
(let ([a (car rands)]) (let ([l (or (exception-label)
(unless (symbol? a) (error who "no exception label"))])
(error who "invalid arg to record-effect ~s" a)) (cons `(jmp ,l) ac))]
(list* `(shrl ,pageshift ,a)
`(sall ,wordshift ,a)
`(addl ,(pcb-ref 'dirty-vector) ,a)
`(movl ,dirty-word (disp 0 ,a))
ac))]
[else (error who "invalid effect ~s" (unparse x))])] [else (error who "invalid effect ~s" (unparse x))])]
[(shortcut^ test body handler) [(shortcut body handler)
(let ([L (unique-label)] [L2 (unique-label)]) (let ([L (unique-label)] [L2 (unique-label)])
(let ([ac (cons L (E handler (cons L2 ac)))]) (let ([ac (cons L (E handler (cons L2 ac)))])
(let ([ac (parameterize ([exception-label L]) (parameterize ([exception-label L])
(E body (cons `(jmp ,L2) ac)))]) (E body (cons `(jmp ,L2) ac)))))]
(P test #f L ac))))]
[else (error who "invalid effect ~s" (unparse x))])) [else (error who "invalid effect ~s" (unparse x))]))
;;; ;;;
(define (unique-label) (define (unique-label)
@ -3926,12 +3932,11 @@
[(direct-jump) [(direct-jump)
(cons `(jmp (label ,(code-loc-label (car rands)))) ac)] (cons `(jmp (label ,(code-loc-label (car rands)))) ac)]
[else (error who "invalid tail ~s" x)])] [else (error who "invalid tail ~s" x)])]
[(shortcut^ test body handler) [(shortcut body handler)
(let ([L (unique-label)]) (let ([L (unique-label)])
(let ([ac (cons L (T handler ac))]) (let ([ac (cons L (T handler ac))])
(let ([ac (parameterize ([exception-label L]) (parameterize ([exception-label L])
(T body ac))]) (T body ac))))]
(P test #f L ac))))]
[else (error who "invalid tail ~s" x)])) [else (error who "invalid tail ~s" x)]))
(define exception-label (make-parameter #f)) (define exception-label (make-parameter #f))
;;; ;;;

5
src/libcompile.ss
View File

@ -256,7 +256,6 @@
(define-record shortcut^ (test body handler))
(define-record shortcut (body handler)) (define-record shortcut (body handler))
(define-record fvar (idx)) (define-record fvar (idx))
@ -483,10 +482,8 @@
[(nframe vars live body) `(nframe ;[vars: ,(map E vars)] [(nframe vars live body) `(nframe ;[vars: ,(map E vars)]
;[live: ,(map E live)] ;[live: ,(map E live)]
,(E body))] ,(E body))]
[(shortcut^ pred body handler)
`(shortcut ,(E pred) ,(E body) ,(E handler))]
[(shortcut body handler) [(shortcut body handler)
`(exceptional ,(E body) ,(E handler))] `(shortcut ,(E body) ,(E handler))]
[else [else
(if (symbol? x) (if (symbol? x)
x x