* fixed bug in the graph construction that caused the operand of
idivl not to be added to the live set.
This commit is contained in:
Abdulaziz Ghuloum
parent
de7c43a16b
commit
e9740fa34f
|
|
@ -77,6 +77,10 @@ setup ()
|
|||
APPS="/opt/bin"
|
||||
LARCENY="/Users/aghuloum/.opt/larceny-0.93-bin-native-ia32-macosx/larceny"
|
||||
PETITE_CHEZ="/usr/bin/petite"
|
||||
CHICKEN="/Users/ikarus/.opt/bin/csc"
|
||||
CHICKEN_INIT="/Users/ikarus/.opt/bin/csi"
|
||||
GSI="/Users/ikarus/.opt/4.0b20/bin/gsi"
|
||||
GSC="/Users/ikarus/.opt/4.0b20/bin/gsc"
|
||||
;;
|
||||
esac
|
||||
|
||||
|
|
|
|||
|
|
@ -3814,3 +3814,254 @@ Words allocated: 8126378
|
|||
Words reclaimed: 0
|
||||
Elapsed time...: 1947 ms (User: 1804 ms; System: 142 ms)
|
||||
Elapsed GC time: 9 ms (CPU: 8 in 31 collections.)
|
||||
|
||||
****************************
|
||||
Benchmarking Larceny-r6rs on Sun Feb 25 21:46: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 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...: 1828 ms (User: 1586 ms; System: 240 ms)
|
||||
Elapsed GC time: 1144 ms (CPU: 1126 in 360 collections.)
|
||||
|
||||
****************************
|
||||
Benchmarking Larceny-r6rs on Sun Feb 25 21:54:45 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 string 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: 7834358
|
||||
Words reclaimed: 0
|
||||
Elapsed time...: 417 ms (User: 396 ms; System: 20 ms)
|
||||
Elapsed GC time: 39 ms (CPU: 36 in 30 collections.)
|
||||
|
||||
****************************
|
||||
Benchmarking Larceny-r6rs on Sun Feb 25 21:56: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 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...: 1440 ms (User: 1432 ms; System: 8 ms)
|
||||
Elapsed GC time: 71 ms (CPU: 68 in 86 collections.)
|
||||
|
||||
****************************
|
||||
Benchmarking Larceny-r6rs on Mon Feb 26 02:21:02 EST 2007 under Darwin adsl-75-19-178-237.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: 10 ms)
|
||||
Elapsed GC time: 95 ms (CPU: 102 in 272 collections.)
|
||||
|
||||
****************************
|
||||
Benchmarking Larceny-r6rs on Mon Feb 26 02:21:57 EST 2007 under Darwin adsl-75-19-178-237.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 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...: 340 ms (User: 257 ms; System: 48 ms)
|
||||
Elapsed GC time: 0 ms (CPU: 0 in 0 collections.)
|
||||
|
||||
****************************
|
||||
Benchmarking Larceny-r6rs on Mon Feb 26 02:25:19 EST 2007 under Darwin adsl-75-19-178-237.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 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...: 701 ms (User: 573 ms; System: 129 ms)
|
||||
Elapsed GC time: 44 ms (CPU: 41 in 73 collections.)
|
||||
|
||||
****************************
|
||||
Benchmarking Larceny-r6rs on Mon Feb 26 02:38:45 EST 2007 under Darwin adsl-75-19-178-237.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 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...: 1473 ms (User: 1463 ms; System: 10 ms)
|
||||
Elapsed GC time: 340 ms (CPU: 338 in 931 collections.)
|
||||
|
||||
****************************
|
||||
Benchmarking Larceny-r6rs on Mon Feb 26 02:45:13 EST 2007 under Darwin adsl-75-19-178-237.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 cpstak 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: 318239878
|
||||
Words reclaimed: 0
|
||||
Elapsed time...: 1478 ms (User: 1472 ms; System: 6 ms)
|
||||
Elapsed GC time: 431 ms (CPU: 438 in 1214 collections.)
|
||||
|
||||
****************************
|
||||
Benchmarking Larceny-r6rs on Mon Feb 26 14:55:46 EST 2007 under Darwin adsl-75-19-178-237.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 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...: 1930 ms (User: 558 ms; System: 751 ms)
|
||||
Elapsed GC time: 11 ms (CPU: 12 in 16 collections.)
|
||||
|
||||
****************************
|
||||
Benchmarking Larceny-r6rs on Mon Feb 26 15:11:40 EST 2007 under Darwin adsl-75-19-178-237.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 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...: 2856 ms (User: 2848 ms; System: 8 ms)
|
||||
Elapsed GC time: 173 ms (CPU: 170 in 460 collections.)
|
||||
|
||||
****************************
|
||||
Benchmarking Larceny-r6rs on Thu Mar 1 00:32:38 EST 2007 under Darwin iub-vpn-194-110.noc.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...: 6579 ms (User: 6509 ms; System: 70 ms)
|
||||
Elapsed GC time: 282 ms (CPU: 298 in 385 collections.)
|
||||
|
|
|
|||
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
|
|
@ -195,13 +195,16 @@
|
|||
[vector vt]
|
||||
[$make-vector vt]
|
||||
[$vector-length vt]
|
||||
[vector-length vt]
|
||||
[$vector-ref v]
|
||||
[vector-ref v]
|
||||
[vector-set! e]
|
||||
[$vector-set! e]
|
||||
|
||||
[$make-string vt]
|
||||
[$string-length vt]
|
||||
[$string-ref vt]
|
||||
[string-ref vt]
|
||||
[$string-set! e]
|
||||
|
||||
[$make-symbol vt]
|
||||
|
|
@ -666,13 +669,117 @@
|
|||
|
||||
|
||||
|
||||
(define (remove-complex-operands x)
|
||||
(define who 'remove-complex-operands)
|
||||
(define (mkbind lhs* rhs* body)
|
||||
(if (null? lhs*) body (make-bind lhs* rhs* body)))
|
||||
(define (simplify* arg* op)
|
||||
(define (partition arg*)
|
||||
(if (null? arg*)
|
||||
(values '() '() '())
|
||||
(let ([a (car arg*)])
|
||||
(let-values ([(lhs* rhs* arg*) (partition (cdr arg*))])
|
||||
(record-case a
|
||||
[(constant) (values lhs* rhs* (cons a arg*))]
|
||||
[(var) (values lhs* rhs* (cons a arg*))]
|
||||
[(code-loc) (values lhs* rhs* (cons a arg*))]
|
||||
[(closure) (values lhs* rhs* (cons a arg*))]
|
||||
[else
|
||||
(let ([t (unique-var 'tmp)])
|
||||
(values (cons t lhs*)
|
||||
(cons a rhs*)
|
||||
(cons t arg*)))])))))
|
||||
(let ([arg* (map V arg*)])
|
||||
(let-values ([(lhs* rhs* arg*) (partition arg*)])
|
||||
(mkbind lhs* rhs* (make-primcall op arg*)))))
|
||||
(define (E x)
|
||||
(record-case x
|
||||
[(bind lhs* rhs* body)
|
||||
(mkbind lhs* (map V rhs*) (E body))]
|
||||
[(fix lhs* rhs* body)
|
||||
(make-fix lhs* rhs* (E body))]
|
||||
[(conditional e0 e1 e2)
|
||||
(make-conditional (P e0) (E e1) (E e2))]
|
||||
[(seq e0 e1)
|
||||
(make-seq (E e0) (E e1))]
|
||||
[(primcall op arg*) (simplify* arg* op)]
|
||||
[(forcall op arg*)
|
||||
(make-forcall op (map V arg*))]
|
||||
[(funcall rator arg*)
|
||||
(make-funcall (V rator) (map V arg*))]
|
||||
[(jmpcall label rator arg*)
|
||||
(make-jmpcall label (V rator) (map V arg*))]
|
||||
[else (error who "invalid effect expr ~s" x)]))
|
||||
(define (P x)
|
||||
(record-case x
|
||||
[(constant) x]
|
||||
[(bind lhs* rhs* body)
|
||||
(mkbind lhs* (map V rhs*) (P body))]
|
||||
[(fix lhs* rhs* body)
|
||||
(make-fix lhs* rhs* (P body))]
|
||||
[(conditional e0 e1 e2)
|
||||
(make-conditional (P e0) (P e1) (P e2))]
|
||||
[(seq e0 e1)
|
||||
(make-seq (E e0) (P e1))]
|
||||
[(primcall op arg*) (simplify* arg* op)]
|
||||
[else (error who "invalid pred expr ~s" x)]))
|
||||
(define (V x)
|
||||
(record-case x
|
||||
[(constant) x]
|
||||
[(var) x]
|
||||
[(primref name) x]
|
||||
[(code-loc) x]
|
||||
[(closure) x]
|
||||
[(bind lhs* rhs* body)
|
||||
(mkbind lhs* (map V rhs*) (V body))]
|
||||
[(fix lhs* rhs* body)
|
||||
(make-fix lhs* rhs* (V body))]
|
||||
[(conditional e0 e1 e2)
|
||||
(make-conditional (P e0) (V e1) (V e2))]
|
||||
[(seq e0 e1)
|
||||
(make-seq (E e0) (V e1))]
|
||||
[(primcall op arg*) (simplify* arg* op)]
|
||||
[(forcall op arg*)
|
||||
(make-forcall op (map V arg*))]
|
||||
[(funcall rator arg*)
|
||||
(make-funcall (V rator) (map V arg*))]
|
||||
[(jmpcall label rator arg*)
|
||||
(make-jmpcall label (V rator) (map V arg*))]
|
||||
[else (error who "invalid value expr ~s" x)]))
|
||||
(define (ClambdaCase x)
|
||||
(record-case x
|
||||
[(clambda-case info body)
|
||||
(make-clambda-case info (V body))]
|
||||
[else (error who "invalid clambda-case ~s" x)]))
|
||||
;;;
|
||||
(define (Clambda x)
|
||||
(record-case x
|
||||
[(clambda label case* free*)
|
||||
(make-clambda label
|
||||
(map ClambdaCase case*)
|
||||
free*)]
|
||||
[else (error who "invalid clambda ~s" x)]))
|
||||
;;;
|
||||
(define (Program x)
|
||||
(record-case x
|
||||
[(codes code* body)
|
||||
(make-codes
|
||||
(map Clambda code*)
|
||||
(V body))]
|
||||
[else (error who "invalid program ~s" x)]))
|
||||
(Program x))
|
||||
|
||||
|
||||
(define-syntax seq*
|
||||
(syntax-rules ()
|
||||
[(_ e) e]
|
||||
[(_ e* ... e)
|
||||
(make-seq (seq* e* ...) e)]))
|
||||
|
||||
(define (specify-representation x)
|
||||
|
||||
(include "pass-specify-rep.ss")
|
||||
|
||||
#;(define (specify-representation x)
|
||||
(define who 'specify-representation)
|
||||
;;;
|
||||
(define fixnum-scale 4)
|
||||
|
|
@ -683,6 +790,7 @@
|
|||
;;;
|
||||
(define nop (make-primcall 'nop '()))
|
||||
;;;
|
||||
(import primops)
|
||||
(define (handle-fix lhs* rhs* body)
|
||||
(define (closure-size x)
|
||||
(record-case x
|
||||
|
|
@ -804,6 +912,13 @@
|
|||
(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))]
|
||||
|
|
@ -857,6 +972,64 @@
|
|||
(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)
|
||||
|
|
@ -972,7 +1145,10 @@
|
|||
[($set-tcbucket-val!) disp-tcbucket-val]
|
||||
[else (err 'tcbucket!)])
|
||||
vector-tag)))]
|
||||
[else (error who "invalid effect prim ~s" op)])]
|
||||
[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*)
|
||||
|
|
@ -1468,6 +1644,57 @@
|
|||
(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*)])
|
||||
|
|
@ -1827,54 +2054,6 @@
|
|||
(tbind ([a0 (Value a0)] [a1 (Value a1)])
|
||||
(prm 'mref (prm 'int+ a0 a1)
|
||||
(K (- disp-vector-data vector-tag))))]))]
|
||||
[(vector-ref)
|
||||
(tbind ([a0 (Value (car arg*))])
|
||||
(let ([a1 (cadr arg*)])
|
||||
(define (do-err who str . args)
|
||||
(make-funcall
|
||||
(Value (make-primref 'error))
|
||||
(list* (Value (K who))
|
||||
(Value (K str))
|
||||
args)))
|
||||
(define (vector-range-check/fixnum x i)
|
||||
(make-conditional
|
||||
(tag-test x vector-mask vector-tag)
|
||||
(tbind ([sec (prm 'mref x (K (- vector-tag)))])
|
||||
(make-conditional
|
||||
(tag-test sec fixnum-mask fixnum-tag)
|
||||
(prm '< (K (* i fixnum-scale)) sec)
|
||||
(make-constant #f)))
|
||||
(make-constant #f)))
|
||||
(define (vector-range-check/var x i)
|
||||
(make-conditional
|
||||
(tag-test x vector-mask vector-tag)
|
||||
(tbind ([sec (prm 'mref x (K (- vector-tag)))])
|
||||
(make-conditional
|
||||
(tag-test (prm 'logor sec i) fixnum-mask fixnum-tag)
|
||||
(prm 'u< i sec)
|
||||
(make-constant #f)))
|
||||
(make-constant #f)))
|
||||
(record-case a1
|
||||
[(constant i)
|
||||
(if (and (fixnum? i) (>= i 0))
|
||||
(make-conditional
|
||||
(vector-range-check/fixnum a0 i)
|
||||
(prm 'mref a0
|
||||
(K (+ (- disp-vector-data vector-tag)
|
||||
(* i wordsize))))
|
||||
(do-err 'vector-ref "~s is not a valid index for ~s"
|
||||
(Value a1) a0))
|
||||
(do-err 'vector-ref "~s is not a valid index for ~s"
|
||||
(Value a1) a0))]
|
||||
|
||||
[else
|
||||
(tbind ([a0 (Value a0)] [a1 (Value a1)])
|
||||
(make-conditional
|
||||
(vector-range-check/var a0 a1)
|
||||
(prm 'mref (prm 'int+ a0 a1)
|
||||
(K (- disp-vector-data vector-tag)))
|
||||
(do-err 'vector-ref "~s is not a valid index for ~s"
|
||||
a1 a0)))])))]
|
||||
[($closure-code)
|
||||
(tbind ([x (Value (car arg*))])
|
||||
(prm 'int+
|
||||
|
|
@ -2060,7 +2239,10 @@
|
|||
(list (make-constant 'apply)
|
||||
(make-constant "~s is not a procedure")
|
||||
x)))))]
|
||||
[else (error who "value prim ~a not supported" (unparse 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*)
|
||||
|
|
@ -3455,7 +3637,7 @@
|
|||
(add-edge! g edx y))
|
||||
s))
|
||||
(union (union (R eax) (R edx))
|
||||
(union (R d) s)))]
|
||||
(union (R v) s)))]
|
||||
[(mset)
|
||||
(union (R v) (union (R d) s))]
|
||||
[else (error who "invalid effect ~s" x)])]
|
||||
|
|
@ -3506,6 +3688,7 @@
|
|||
[else (error who "invalid tail ~s" (unparse x))]))
|
||||
(define exception-live-set (make-parameter #f))
|
||||
(let ([s (T x)])
|
||||
;(pretty-print (unparse x))
|
||||
;(print-graph g)
|
||||
g))
|
||||
;;;
|
||||
|
|
@ -4094,19 +4277,19 @@
|
|||
(define (notop x)
|
||||
(cond
|
||||
[(assq x '([= !=] [!= =] [< >=] [<= >] [> <=] [>= <]
|
||||
[u< u>=]))
|
||||
[u< u>=] [u<= u>] [u> u<=] [u>= u<]))
|
||||
=> cadr]
|
||||
[else (error who "invalid op ~s" x)]))
|
||||
(define (jmpname x)
|
||||
(cond
|
||||
[(assq x '([= je] [!= jne] [< jl] [<= jle] [> jg] [>= jge]
|
||||
[u< jb]))
|
||||
[u< jb] [u<= jbe] [u> ja] [u>= jae]))
|
||||
=> cadr]
|
||||
[else (error who "invalid jmpname ~s" x)]))
|
||||
(define (revjmpname x)
|
||||
(cond
|
||||
[(assq x '([= je] [!= jne] [< jg] [<= jge] [> jl] [>= jle]
|
||||
[u< ja]))
|
||||
[u< ja] [u<= jae] [u> jb] [u>= jbe]))
|
||||
=> cadr]
|
||||
[else (error who "invalid jmpname ~s" x)]))
|
||||
(define (cmp op a0 a1 lab ac)
|
||||
|
|
@ -4291,6 +4474,7 @@
|
|||
;[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)]
|
||||
|
|
|
|||
|
|
@ -317,7 +317,6 @@
|
|||
[(and (int? i2) (obj? i1)) (IMM32*2 i2 i1 ac)]
|
||||
[else (error 'assemble "IMM32*2 ~s ~s" i1 i2)])))
|
||||
|
||||
|
||||
(define CODErd
|
||||
(lambda (c r1 disp ac)
|
||||
(with-args disp
|
||||
|
|
@ -377,22 +376,6 @@
|
|||
[else (error 'CODE/digit "unhandled ~s ~s" a0 a1)])))]
|
||||
[else (error 'CODE/digit "unhandled ~s" dst)])))
|
||||
|
||||
; 01 /r ADD r/m32, r32 Valid Add r32 to r/m32.
|
||||
;;;(define (CODE/r c /r)
|
||||
;;; (lambda (dst ac)
|
||||
;;; (cond
|
||||
;;; [(mem? dst)
|
||||
;;; (with-args dst
|
||||
;;; (lambda (a0 a1)
|
||||
;;; (cond
|
||||
;;; [(and (imm8? a0) (reg? a1))
|
||||
;;; (CODE c (ModRM 1 /r a1 (IMM8 a0 ac)))]
|
||||
;;; [else (error 'CODE/r "unhandled ~s ~s" a0 a1)])))]
|
||||
;;; [else (error 'CODE/r "unhandled ~s" dst)])))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(define CODEid
|
||||
(lambda (c /? n disp ac)
|
||||
|
|
@ -633,8 +616,10 @@
|
|||
[(and (mem? src) (reg? dst))
|
||||
(CODErd #x3B dst src ac)]
|
||||
[(and (imm8? src) (mem? dst))
|
||||
;;; maybe error
|
||||
(CODErd #x83 '/7 dst (IMM8 src ac))]
|
||||
[(and (imm? src) (mem? dst))
|
||||
;;; maybe error
|
||||
(CODErd #x81 '/7 dst (IMM32 src ac))]
|
||||
[else (error who "invalid ~s" instr)])]
|
||||
[(imull src dst)
|
||||
|
|
@ -653,6 +638,7 @@
|
|||
[(reg? dst)
|
||||
(CODErr #xF7 '/7 dst ac)]
|
||||
[(mem? dst)
|
||||
;;; maybe error
|
||||
(CODErd #xF7 '/7 dst ac)]
|
||||
[else (error who "invalid ~s" instr)])]
|
||||
[(pushl dst)
|
||||
|
|
@ -664,6 +650,7 @@
|
|||
[(reg? dst)
|
||||
(CODE+r #x50 dst ac)]
|
||||
[(mem? dst)
|
||||
;;; maybe error
|
||||
(CODErd #xFF '/6 dst ac)]
|
||||
[else (error who "invalid ~s" instr)])]
|
||||
[(popl dst)
|
||||
|
|
@ -671,6 +658,7 @@
|
|||
[(reg? dst)
|
||||
(CODE+r #x58 dst ac)]
|
||||
[(mem? dst)
|
||||
;;; maybe error
|
||||
(CODErd #x8F '/0 dst ac)]
|
||||
[else (error who "invalid ~s" instr)])]
|
||||
[(notl dst)
|
||||
|
|
@ -678,6 +666,7 @@
|
|||
[(reg? dst)
|
||||
(CODE #xF7 (ModRM 3 '/2 dst ac))]
|
||||
[(mem? dst)
|
||||
;;; maybe error
|
||||
(CODErd #xF7 '/7 dst ac)]
|
||||
[else (error who "invalid ~s" instr)])]
|
||||
[(negl dst)
|
||||
|
|
@ -692,6 +681,7 @@
|
|||
[(imm? dst)
|
||||
(CODE #xE9 (IMM32 dst ac))]
|
||||
[(mem? dst)
|
||||
;;; maybe error
|
||||
(CODErd #xFF '/4 dst ac)]
|
||||
[else (error who "invalid jmp target ~s" dst)])]
|
||||
[(call dst)
|
||||
|
|
@ -701,6 +691,7 @@
|
|||
[(label? dst)
|
||||
(CODE #xE8 (cons (cons 'relative (label-name dst)) ac))]
|
||||
[(mem? dst)
|
||||
;;; maybe error
|
||||
(CODErd #xFF '/2 dst ac)]
|
||||
[(reg? dst)
|
||||
(CODE #xFF (ModRM 3 '/2 dst ac))]
|
||||
|
|
|
|||
Loading…
Reference in New Issue