diff --git a/benchmarks/bench b/benchmarks/bench index f7ad9b4..d9f6871 100755 --- a/benchmarks/bench +++ b/benchmarks/bench @@ -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 diff --git a/benchmarks/results.Larceny-r6rs b/benchmarks/results.Larceny-r6rs index 247cb17..060e86a 100644 --- a/benchmarks/results.Larceny-r6rs +++ b/benchmarks/results.Larceny-r6rs @@ -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.) diff --git a/src/ikarus.boot b/src/ikarus.boot index 57a4ab8..08c21d4 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/libaltcogen.ss b/src/libaltcogen.ss index cb9fda7..aea4970 100644 --- a/src/libaltcogen.ss +++ b/src/libaltcogen.ss @@ -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)] diff --git a/src/libintelasm.ss b/src/libintelasm.ss index 2660fdf..db4fac2 100644 --- a/src/libintelasm.ss +++ b/src/libintelasm.ss @@ -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))]