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

* fixed an assembler bug in "addl reg -> mem"

This commit is contained in:
Abdulaziz Ghuloum 2007-02-13 17:24:00 -05:00
parent 297e47db32
commit 8294a8dee9
8 changed files with 363 additions and 136 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
bin/Makefile
View File

@ -1,6 +1,6 @@
#CFLAGS = -I/opt/local/include -Wall -DNDEBUG -O3 #-fomit-frame-pointer CFLAGS = -I/opt/local/include -Wall -DNDEBUG -O3 #-fomit-frame-pointer
CFLAGS = -I/opt/local/include -Wall -g #CFLAGS = -I/opt/local/include -Wall -g
LDFLAGS = -L/opt/local/lib -g -ldl -lgmp #-rdynamic LDFLAGS = -L/opt/local/lib -g -ldl -lgmp #-rdynamic
CC = gcc CC = gcc
all: ikarus all: ikarus

BIN
bin/ikarus
View File

Binary file not shown.

16
src/asm-tests.ss Normal file → Executable file
View File

@ -1,4 +1,4 @@
#!/usr/bin/env ikarus --script
(define (asm-test res ls) (define (asm-test res ls)
(printf "Testing:\n") (printf "Testing:\n")
(for-each (lambda (x) (for-each (lambda (x)
@ -50,6 +50,20 @@
[movl (disp -4 %esp) %eax] [movl (disp -4 %esp) %eax]
[ret])) [ret]))
(asm-test 2
'([movl 4 %ebx]
[movl 4 (disp -8 %esp)]
[addl %ebx (disp -8 %esp)]
[movl (disp -8 %esp) %eax]
[ret]))
(asm-test 2
'([movl 4 %eax]
[movl 4 (disp -8 %esp)]
[addl %eax (disp -8 %esp)]
[movl 0 %eax]
[movl (disp -8 %esp) %eax]
[ret]))

5
src/geninstr/gen.pl
View File

@ -48,7 +48,10 @@ sub gen3{
} }
} }
gen1 "addl \$0x12345678, 7(r1)\n"; #gen1 "addl \$0x12345678, 7(r1)\n";
#gen2 "addl 0x23(r1), r2\n";
gen2 "addl r1, 0x23(r2)\n";
#gen1 "movb \$0, 4(r1)\n"; #gen1 "movb \$0, 4(r1)\n";
#gen1 "movb -2(r1), %ah\n"; #gen1 "movb -2(r1), %ah\n";

72
src/geninstr/tmp.s
View File

@ -1,9 +1,65 @@
.text .text
addl $0x12345678, 7(%eax) addl %eax, 0x23(%eax)
addl $0x12345678, 7(%ecx) addl %eax, 0x23(%ecx)
addl $0x12345678, 7(%edx) addl %eax, 0x23(%edx)
addl $0x12345678, 7(%ebx) addl %eax, 0x23(%ebx)
addl $0x12345678, 7(%esp) addl %eax, 0x23(%esp)
addl $0x12345678, 7(%ebp) addl %eax, 0x23(%ebp)
addl $0x12345678, 7(%esi) addl %eax, 0x23(%esi)
addl $0x12345678, 7(%edi) addl %eax, 0x23(%edi)
addl %ecx, 0x23(%eax)
addl %ecx, 0x23(%ecx)
addl %ecx, 0x23(%edx)
addl %ecx, 0x23(%ebx)
addl %ecx, 0x23(%esp)
addl %ecx, 0x23(%ebp)
addl %ecx, 0x23(%esi)
addl %ecx, 0x23(%edi)
addl %edx, 0x23(%eax)
addl %edx, 0x23(%ecx)
addl %edx, 0x23(%edx)
addl %edx, 0x23(%ebx)
addl %edx, 0x23(%esp)
addl %edx, 0x23(%ebp)
addl %edx, 0x23(%esi)
addl %edx, 0x23(%edi)
addl %ebx, 0x23(%eax)
addl %ebx, 0x23(%ecx)
addl %ebx, 0x23(%edx)
addl %ebx, 0x23(%ebx)
addl %ebx, 0x23(%esp)
addl %ebx, 0x23(%ebp)
addl %ebx, 0x23(%esi)
addl %ebx, 0x23(%edi)
addl %esp, 0x23(%eax)
addl %esp, 0x23(%ecx)
addl %esp, 0x23(%edx)
addl %esp, 0x23(%ebx)
addl %esp, 0x23(%esp)
addl %esp, 0x23(%ebp)
addl %esp, 0x23(%esi)
addl %esp, 0x23(%edi)
addl %ebp, 0x23(%eax)
addl %ebp, 0x23(%ecx)
addl %ebp, 0x23(%edx)
addl %ebp, 0x23(%ebx)
addl %ebp, 0x23(%esp)
addl %ebp, 0x23(%ebp)
addl %ebp, 0x23(%esi)
addl %ebp, 0x23(%edi)
addl %esi, 0x23(%eax)
addl %esi, 0x23(%ecx)
addl %esi, 0x23(%edx)
addl %esi, 0x23(%ebx)
addl %esi, 0x23(%esp)
addl %esi, 0x23(%ebp)
addl %esi, 0x23(%esi)
addl %esi, 0x23(%edi)
addl %edi, 0x23(%eax)
addl %edi, 0x23(%ecx)
addl %edi, 0x23(%edx)
addl %edi, 0x23(%ebx)
addl %edi, 0x23(%esp)
addl %edi, 0x23(%ebp)
addl %edi, 0x23(%esi)
addl %edi, 0x23(%edi)

BIN
src/ikarus.boot
View File

Binary file not shown.

263
src/libaltcogen.ss
View File

@ -147,6 +147,7 @@
[$fxsll v] [$fxsll v]
[$fxsra v] [$fxsra v]
[$fxlogand v] [$fxlogand v]
[$fxlognot v]
[$fxmodulo v] [$fxmodulo v]
[$fxzero? p] [$fxzero? p]
[$fx> p] [$fx> p]
@ -159,7 +160,9 @@
[$char<= p] [$char<= p]
[$char= p] [$char= p]
[$char->fixnum v] [$char->fixnum v]
[$fixnum->char v]
[$make-vector v]
[$vector-ref v] [$vector-ref v]
[$vector-set! e] [$vector-set! e]
@ -191,6 +194,9 @@
[$seal-frame-and-call tail] [$seal-frame-and-call tail]
[$frame->continuation v] [$frame->continuation v]
[$make-call-with-values-procedure v]
[$make-values-procedure v]
)) ))
(define library-prims (define library-prims
'(vector '(vector
@ -319,38 +325,45 @@
(make-primcall '$cpref (list cpvar (make-constant i)))] (make-primcall '$cpref (list cpvar (make-constant i)))]
[else (f (cdr free*) (fxadd1 i))]))) [else (f (cdr free*) (fxadd1 i))])))
;;; ;;;
(define (make-closure x) ;;; (define (make-closure x)
(record-case x ;;; (record-case x
[(closure code free*) ;;; [(closure code free*)
(cond ;;; (cond
[(null? free*) x] ;;; [(null? free*) x]
[else ;;; [else
(make-primcall '$make-cp ;;; (make-primcall '$make-cp
(list code (make-constant (length free*))))])])) ;;; (list code (make-constant (length free*))))])]))
;;; ;;; ;;;
(define (closure-sets var x ac) ;;; (define (closure-sets var x ac)
(record-case x ;;; (record-case x
[(closure code free*) ;;; [(closure code free*)
(let f ([i 0] [free* free*]) ;;; (let f ([i 0] [free* free*])
(cond ;;; (cond
[(null? free*) ac] ;;; [(null? free*) ac]
[else ;;; [else
(make-seq ;;; (make-seq
(make-primcall '$cpset! ;;; (make-primcall '$cpset!
(list var (make-constant i) ;;; (list var (make-constant i)
(Var (car free*)))) ;;; (Var (car free*))))
(f (fxadd1 i) (cdr free*)))]))])) ;;; (f (fxadd1 i) (cdr free*)))]))]))
;;;
;;; (define (do-fix lhs* rhs* body)
;;; (make-bind
;;; lhs* (map make-closure rhs*)
;;; (let f ([lhs* lhs*] [rhs* rhs*])
;;; (cond
;;; [(null? lhs*) body]
;;; [else
;;; (closure-sets (car lhs*) (car rhs*)
;;; (f (cdr lhs*) (cdr rhs*)))]))))
(define (do-fix lhs* rhs* body) (define (do-fix lhs* rhs* body)
(make-bind (define (handle-closure x)
lhs* (map make-closure rhs*) (record-case x
(let f ([lhs* lhs*] [rhs* rhs*]) [(closure code free*)
(cond (make-closure code (map Var free*))]))
[(null? lhs*) body] (make-fix lhs* (map handle-closure rhs*) body))
[else
(closure-sets (car lhs*) (car rhs*)
(f (cdr lhs*) (cdr rhs*)))]))))
;;;
(define (Expr x) (define (Expr x)
(record-case x (record-case x
[(constant) x] [(constant) x]
@ -364,7 +377,7 @@
(make-conditional (Expr e0) (Expr e1) (Expr e2))] (make-conditional (Expr e0) (Expr e1) (Expr e2))]
[(seq e0 e1) [(seq e0 e1)
(make-seq (Expr e0) (Expr e1))] (make-seq (Expr e0) (Expr e1))]
[(closure) [(closure)
(let ([t (unique-var 'tmp)]) (let ([t (unique-var 'tmp)])
(Expr (make-fix (list t) (list x) t)))] (Expr (make-fix (list t) (list x) t)))]
[(primcall op arg*) [(primcall op arg*)
@ -455,6 +468,8 @@
[(funcall) (Predicafy x)] [(funcall) (Predicafy x)]
[(jmpcall) (Predicafy x)] [(jmpcall) (Predicafy x)]
[(forcall) (Predicafy x)] [(forcall) (Predicafy x)]
[(fix lhs* rhs* body)
(make-fix lhs* rhs* (P body))]
[(primcall op rands) [(primcall op rands)
(case (prim-context op) (case (prim-context op)
[(v) (Predicafy x)] [(v) (Predicafy x)]
@ -479,6 +494,8 @@
(mkseq (E e0) (E e1))] (mkseq (E e0) (E e1))]
[(bind lhs* rhs* body) [(bind lhs* rhs* body)
(mkbind lhs* (map V rhs*) (E body))] (mkbind lhs* (map V rhs*) (E body))]
[(fix lhs* rhs* body)
(make-fix lhs* rhs* (E body))]
[(conditional e0 e1 e2) [(conditional e0 e1 e2)
(let ([e1 (E e1)] [e2 (E e2)]) (let ([e1 (E e1)] [e2 (E e2)])
(cond (cond
@ -516,6 +533,8 @@
(mkif (P e0) (V e1) (V e2))] (mkif (P e0) (V e1) (V e2))]
[(bind lhs* rhs* body) [(bind lhs* rhs* body)
(mkbind lhs* (map V rhs*) (V body))] (mkbind lhs* (map V rhs*) (V body))]
[(fix lhs* rhs* body)
(make-fix lhs* rhs* (V body))]
[(funcall rator rand*) [(funcall rator rand*)
(make-funcall (V rator) (map V rand*))] (make-funcall (V rator) (map V rand*))]
[(jmpcall label rator rand*) [(jmpcall label rator rand*)
@ -577,6 +596,83 @@
;;; ;;;
(define nop (make-primcall 'nop '())) (define nop (make-primcall 'nop '()))
;;; ;;;
(define (handle-fix lhs* rhs* body)
(define (closure-size x)
(record-case x
[(closure code free*)
(if (null? free*)
0
(align (+ disp-closure-data
(* (length free*) wordsize))))]))
(define (partition p? lhs* rhs*)
(cond
[(null? lhs*) (values '() '() '() '())]
[else
(let-values ([(a* b* c* d*)
(partition p? (cdr lhs*) (cdr rhs*))]
[(x y) (values (car lhs*) (car rhs*))])
(cond
[(p? x y)
(values (cons x a*) (cons y b*) c* d*)]
[else
(values a* b* (cons x c*) (cons y d*))]))]))
(define (combinator? lhs rhs)
(record-case rhs
[(closure code free*) (null? free*)]))
(define (sum n* n)
(cond
[(null? n*) n]
[else (sum (cdr n*) (+ n (car n*)))]))
(define (adders lhs n n*)
(cond
[(null? n*) '()]
[else
(cons (prm 'int+ (list lhs (K n)))
(adders lhs (+ n (car n*)) (cdr n*)))]))
(define (build-closures lhs* rhs* body)
(let ([lhs (car lhs*)] [rhs (car rhs*)]
[lhs* (cdr lhs*)] [rhs* (cdr rhs*)])
(let ([n (closure-size rhs)]
[n* (map closure-size rhs*)])
(make-bind (list lhs)
(list (prm 'alloc
(K (sum n* n))
(K closure-tag)))
(make-bind lhs* (adders lhs n n*)
body)))))
(define (build-setters lhs* rhs* body)
(define (build-setter lhs rhs body)
(record-case rhs
[(closure code free*)
(make-seq
(prm 'mset! lhs
(K (- disp-closure-code closure-tag))
(Value code))
(let f ([ls free*]
[i (- disp-closure-data closure-tag)])
(cond
[(null? ls) body]
[else
(make-seq
(prm 'mset! lhs (K i) (Value (car ls)))
(f (cdr ls) (+ i wordsize)))])))]))
(cond
[(null? lhs*) body]
[else
(build-setter (car lhs*) (car rhs*)
(build-setters (cdr lhs*) (cdr rhs*) body))]))
(let-values ([(flhs* frhs* clhs* crhs*)
(partition combinator? lhs* rhs*)])
(cond
[(null? clhs*) (make-bind flhs* (map Value frhs*) body)]
[(null? flhs*)
(build-closures clhs* crhs*
(build-setters clhs* crhs* body))]
[else
(make-bind flhs* (map Value frhs*)
(build-closures clhs* crhs*
(build-setters clhs* crhs* body)))])))
;;;
(define (constant-rep x) (define (constant-rep x)
(let ([c (constant-value x)]) (let ([c (constant-value x)])
(cond (cond
@ -619,6 +715,8 @@
(make-conditional (Pred e0) (Effect e1) (Effect e2))] (make-conditional (Pred e0) (Effect e1) (Effect e2))]
[(seq e0 e1) [(seq e0 e1)
(make-seq (Effect e0) (Effect e1))] (make-seq (Effect e0) (Effect e1))]
[(fix lhs* rhs* body)
(handle-fix lhs* rhs* (Effect body))]
[(primcall op arg*) [(primcall op arg*)
(case op (case op
[(nop) nop] [(nop) nop]
@ -694,6 +792,8 @@
(make-conditional (Pred e0) (Pred e1) (Pred e2))] (make-conditional (Pred e0) (Pred e1) (Pred e2))]
[(seq e0 e1) [(seq e0 e1)
(make-seq (Effect e0) (Pred e1))] (make-seq (Effect e0) (Pred e1))]
[(fix lhs* rhs* body)
(handle-fix lhs* rhs* (Pred body))]
[(primcall op arg*) [(primcall op arg*)
(case op (case op
[(eq?) (make-primcall '= (map Value arg*))] [(eq?) (make-primcall '= (map Value arg*))]
@ -767,6 +867,14 @@
;;; ;;;
(define (err x) (define (err x)
(error who "invalid form ~s" (unparse x))) (error who "invalid form ~s" (unparse x)))
;;;
(define (align-code unknown-amt known-amt)
(prm 'sll
(prm 'sra
(prm 'int+ unknown-amt
(K (+ known-amt (sub1 object-alignment))))
(K align-shift))
(K align-shift)))
;;; value ;;; value
(define (Value x) (define (Value x)
(record-case x (record-case x
@ -780,6 +888,8 @@
[(closure) (make-constant x)] [(closure) (make-constant x)]
[(bind lhs* rhs* body) [(bind lhs* rhs* body)
(make-bind lhs* (map Value rhs*) (Value body))] (make-bind lhs* (map Value rhs*) (Value body))]
[(fix lhs* rhs* body)
(handle-fix lhs* rhs* (Value body))]
[(conditional e0 e1 e2) [(conditional e0 e1 e2)
(make-conditional (Pred e0) (Value e1) (Value e2))] (make-conditional (Pred e0) (Value e1) (Value e2))]
[(seq e0 e1) [(seq e0 e1)
@ -832,6 +942,31 @@
(make-seq (make-seq
(prm 'mset! t (K i) (car t*)) (prm 'mset! t (K i) (car t*))
(f (cdr t*) (+ i wordsize)))]))))))))] (f (cdr t*) (+ i wordsize)))]))))))))]
[($make-vector)
(unless (= (length arg*) 1)
(error who "incorrect args to $make-vector"))
(let ([len (car arg*)])
(record-case len
[(constant i)
(unless (fixnum? i) (error who "invalid ~s" x))
(tbind ([v (prm 'alloc
(K (align (+ (* i wordsize)
disp-vector-data)))
(K vector-tag))])
(seq*
(prm 'mset! v
(K (- disp-vector-length vector-tag))
(K (make-constant (* i fixnum-scale))))
v))]
[else
(tbind ([len (Value len)])
(tbind ([alen (align-code len disp-vector-data)])
(tbind ([v (prm 'alloc alen (K vector-tag))])
(seq*
(prm 'mset! v
(K (- disp-vector-length vector-tag))
len)
v))))]))]
[($make-record) [($make-record)
(let ([rtd (car arg*)] [len (cadr arg*)]) (let ([rtd (car arg*)] [len (cadr arg*)])
(tbind ([rtd (Value rtd)]) (tbind ([rtd (Value rtd)])
@ -849,20 +984,14 @@
rtd) rtd)
t))] t))]
[else [else
(tbind ([ln (tbind ([len (Value len)])
(prm 'sll (tbind ([ln (align-code len disp-record-data)])
(prm 'sra (tbind ([t (prm 'alloc ln (K vector-tag))])
(prm 'int+ (Value len) (seq*
(K (+ disp-record-data (prm 'mset! t
(sub1 object-alignment)))) (K (- disp-record-rtd vector-tag))
(K align-shift)) rtd)
(K align-shift))]) t))))])))]
(tbind ([t (prm 'alloc ln (K vector-tag))])
(seq*
(prm 'mset! t
(K (- disp-record-rtd vector-tag))
rtd)
t)))])))]
[($record-rtd) [($record-rtd)
(prm 'mref (Value (car arg*)) (prm 'mref (Value (car arg*))
(K (- disp-record-rtd vector-tag)))] (K (- disp-record-rtd vector-tag)))]
@ -906,10 +1035,19 @@
[else (error who "nonconst arg to fxsra ~s" c)]))] [else (error who "nonconst arg to fxsra ~s" c)]))]
[($fxlogand) [($fxlogand)
(prm 'logand (Value (car arg*)) (Value (cadr arg*)))] (prm 'logand (Value (car arg*)) (Value (cadr arg*)))]
[($fxlogxor)
(prm 'logxor (Value (car arg*)) (Value (cadr arg*)))]
[($fxlognot)
(Value (prm '$fxlogxor (car arg*) (K -1)))]
[($char->fixnum) [($char->fixnum)
(prm 'sra (prm 'sra
(Value (car arg*)) (Value (car arg*))
(K (- char-shift fixnum-shift)))] (K (- char-shift fixnum-shift)))]
[($fixnum->char)
(prm 'logor
(prm 'sll (Value (car arg*))
(K (- char-shift fixnum-shift)))
(K char-tag))]
[($current-frame) ;; PCB NEXT-CONTINUATION [($current-frame) ;; PCB NEXT-CONTINUATION
(prm 'mref pcr (K 20))] (prm 'mref pcr (K 20))]
[($seal-frame-and-call) [($seal-frame-and-call)
@ -947,12 +1085,15 @@
(seq* (seq*
(prm 'mset! t (prm 'mset! t
(K (- disp-closure-code closure-tag)) (K (- disp-closure-code closure-tag))
(make-constant (K (make-code-loc SL_continuation_code)))
(make-code-loc SL_continuation_code)))
(prm 'mset! t (prm 'mset! t
(K (- disp-closure-data closure-tag)) (K (- disp-closure-data closure-tag))
arg) arg)
t)))] t)))]
[($make-call-with-values-procedure)
(K (make-closure (make-code-loc SL_call_with_values) '()))]
[($make-values-procedure)
(K (make-closure (make-code-loc SL_values) '()))]
[($cpref) [($cpref)
(let ([a0 (car arg*)] [a1 (cadr arg*)]) (let ([a0 (car arg*)] [a1 (cadr arg*)])
(record-case a1 (record-case a1
@ -1158,7 +1299,7 @@
(S* rands (S* rands
(lambda (rands) (lambda (rands)
(make-set d (make-disp (car rands) (cadr rands)))))] (make-set d (make-disp (car rands) (cadr rands)))))]
[(logand logxor int+ int-) [(logand logxor logor int+ int-)
(make-seq (make-seq
(V d (car rands)) (V d (car rands))
(S (cadr rands) (S (cadr rands)
@ -1224,10 +1365,7 @@
(caddr s*))))] (caddr s*))))]
[(nop) x] [(nop) x]
[else (error 'impose-effect "invalid instr ~s" x)])] [else (error 'impose-effect "invalid instr ~s" x)])]
; (S* rands [(funcall rator rands)
; (lambda (rands)
; (make-primcall op rands)))]
[(funcall rator rands)
(handle-nontail-call rator rands #f #f)] (handle-nontail-call rator rands #f #f)]
[(jmpcall label rator rands) [(jmpcall label rator rands)
(handle-nontail-call rator rands #f label)] (handle-nontail-call rator rands #f label)]
@ -1246,9 +1384,17 @@
[(bind lhs* rhs* e) [(bind lhs* rhs* e)
(do-bind lhs* rhs* (P e))] (do-bind lhs* rhs* (P e))]
[(primcall op rands) [(primcall op rands)
(S* rands (let ([a (car rands)] [b (cadr rands)])
(lambda (rands) (cond
(make-asm-instr op (car rands) (cadr rands))))] [(and (constant? a) (constant? b))
(let ([t (unique-var 'tmp)])
(P (make-bind (list t) (list a)
(make-primcall op (list t b)))))]
[else
(S* rands
(lambda (rands)
(let ([a (car rands)] [b (cadr rands)])
(make-asm-instr op a b))))]))]
[else (error who "invalid pred ~s" x)])) [else (error who "invalid pred ~s" x)]))
;;; ;;;
(define (handle-tail-call target rator rands) (define (handle-tail-call target rator rands)
@ -1842,7 +1988,7 @@
(make-conditional (P e0) (E e1) (E e2))] (make-conditional (P e0) (E e1) (E e2))]
[(asm-instr op a b) [(asm-instr op a b)
(case op (case op
[(logor logand int+ int-) [(logor logxor logand int+ int-)
(cond (cond
[(and (mem? a) (mem? b)) [(and (mem? a) (mem? b))
(let ([u (mku)]) (let ([u (mku)])
@ -2304,9 +2450,8 @@
(let* ( (let* (
;[foo (print-code x)] ;[foo (print-code x)]
[x (remove-primcalls x)] [x (remove-primcalls x)]
;[foo (printf "1")]
[x (eliminate-fix x)] [x (eliminate-fix x)]
;[foo (printf "2")] ;[foo (printf "1")]
[x (normalize-context x)] [x (normalize-context x)]
;[foo (printf "3")] ;[foo (printf "3")]
;[foo (print-code x)] ;[foo (print-code x)]

139
src/libintelasm.ss
View File

@ -67,14 +67,14 @@
[%ch 8 5] [%ch 8 5]
[%dh 8 6] [%dh 8 6]
[%bh 8 7] [%bh 8 7]
[/0 0 0] [/0 0 0]
[/1 0 1] [/1 0 1]
[/2 0 2] [/2 0 2]
[/3 0 3] [/3 0 3]
[/4 0 4] [/4 0 4]
[/5 0 5] [/5 0 5]
[/6 0 6] [/6 0 6]
[/7 0 7] [/7 0 7]
)) ))
(define register-index (define register-index
@ -314,15 +314,6 @@
ac)]))) ac)])))
;;(define CODErd
;; (lambda (c r1 disp ac)
;; (with-args disp
;; (lambda (i/r r2)
;; (if (reg? i/r)
;; (CODE c (RegReg r1 i/r r2 ac))
;; (CODErri c r1 r2 i/r ac))))))
(define IMM32*2 (define IMM32*2
(lambda (i1 i2 ac) (lambda (i1 i2 ac)
(cond (cond
@ -365,8 +356,8 @@
(error 'CODEdi "unsupported2")] (error 'CODEdi "unsupported2")]
[else (error 'CODEdi "unhandled ~s" disp)]))))) [else (error 'CODEdi "unhandled ~s" disp)])))))
; 81 /0 id ADD r/m32,imm32 Valid Valid Add imm32 to ; 81 /0 id ADD r/m32,imm32 Valid Add imm32 to
(define (CODE/r c /?) (define (CODE/digit c /d)
(lambda (dst ac) (lambda (dst ac)
(cond (cond
[(mem? dst) [(mem? dst)
@ -374,9 +365,26 @@
(lambda (a0 a1) (lambda (a0 a1)
(cond (cond
[(and (imm8? a0) (reg? a1)) [(and (imm8? a0) (reg? a1))
(CODE c (ModRM 1 /? a1 (IMM8 a0 ac)))] (CODE c (ModRM 1 /d a1 (IMM8 a0 ac)))]
[else (error 'CODE/r "unhandled ~s ~s" a0 a1)])))] [else (error 'CODE/digit "unhandled ~s ~s" a0 a1)])))]
[else (error 'CODE/r "unhandled ~s" dst)]))) [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 (define CODEid
(lambda (c /? n disp ac) (lambda (c /? n disp ac)
@ -501,9 +509,10 @@
[(and (mem? src) (reg? dst)) [(and (mem? src) (reg? dst))
(CODErd #x03 dst src ac)] (CODErd #x03 dst src ac)]
[(and (imm? src) (mem? dst)) [(and (imm? src) (mem? dst))
((CODE/r #x81 '/0) dst (IMM32 src ac))] ((CODE/digit #x81 '/0) dst (IMM32 src ac))]
[(and (reg? src) (mem? dst)) [(and (reg? src) (mem? dst))
(CODErd #x81 src dst ac)] (printf "code=~s\n" ((CODE/digit #x01 src) dst '()))
((CODE/digit #x01 src) dst ac)]
[else (error who "invalid ~s" instr)])] [else (error who "invalid ~s" instr)])]
[(subl src dst) [(subl src dst)
(cond (cond
@ -526,8 +535,8 @@
(CODE #xC1 (ModRM 3 '/4 dst (IMM8 src ac)))] (CODE #xC1 (ModRM 3 '/4 dst (IMM8 src ac)))]
[(and (imm8? src) (mem? dst)) [(and (imm8? src) (mem? dst))
(printf "sall ~s ~s\n" src dst) (printf "sall ~s ~s\n" src dst)
(printf "=> ~s\n" ((CODE/r #xC1 '/4) dst (IMM8 src '()))) (printf "=> ~s\n" ((CODE/digit #xC1 '/4) dst (IMM8 src '())))
((CODE/r #xC1 '/4) dst (IMM8 src ac))] ((CODE/digit #xC1 '/4) dst (IMM8 src ac))]
[(and (eq? src '%cl) (reg? dst)) [(and (eq? src '%cl) (reg? dst))
(CODE #xD3 (ModRM 3 '/4 dst ac))] (CODE #xD3 (ModRM 3 '/4 dst ac))]
[else (error who "invalid ~s" instr)])] [else (error who "invalid ~s" instr)])]
@ -548,8 +557,8 @@
(CODE #xC1 (ModRM 3 '/7 dst (IMM8 src ac)))] (CODE #xC1 (ModRM 3 '/7 dst (IMM8 src ac)))]
[(and (imm8? src) (mem? dst)) [(and (imm8? src) (mem? dst))
(printf "sarl ~s ~s\n" src dst) (printf "sarl ~s ~s\n" src dst)
(printf "=> ~s\n" ((CODE/r #xC1 '/7) dst (IMM8 src '()))) (printf "=> ~s\n" ((CODE/digit #xC1 '/7) dst (IMM8 src '())))
((CODE/r #xC1 '/7) dst (IMM8 src ac))] ((CODE/digit #xC1 '/7) dst (IMM8 src ac))]
[(and (eq? src '%cl) (reg? dst)) [(and (eq? src '%cl) (reg? dst))
(CODE #xD3 (ModRM 3 '/7 dst ac))] (CODE #xD3 (ModRM 3 '/7 dst ac))]
[else (error who "invalid ~s" instr)])] [else (error who "invalid ~s" instr)])]
@ -680,43 +689,43 @@
[(reg? dst) [(reg? dst)
(CODE #xFF (ModRM 3 '/2 dst ac))] (CODE #xFF (ModRM 3 '/2 dst ac))]
[else (error who "invalid jmp target ~s" dst)])] [else (error who "invalid jmp target ~s" dst)])]
[(seta dst) (conditional-set #x97 dst ac)] [(seta dst) (conditional-set #x97 dst ac)]
[(setae dst) (conditional-set #x93 dst ac)] [(setae dst) (conditional-set #x93 dst ac)]
[(setb dst) (conditional-set #x92 dst ac)] [(setb dst) (conditional-set #x92 dst ac)]
[(setbe dst) (conditional-set #x96 dst ac)] [(setbe dst) (conditional-set #x96 dst ac)]
[(setg dst) (conditional-set #x9F dst ac)] [(setg dst) (conditional-set #x9F dst ac)]
[(setge dst) (conditional-set #x9D dst ac)] [(setge dst) (conditional-set #x9D dst ac)]
[(setl dst) (conditional-set #x9C dst ac)] [(setl dst) (conditional-set #x9C dst ac)]
[(setle dst) (conditional-set #x9E dst ac)] [(setle dst) (conditional-set #x9E dst ac)]
[(sete dst) (conditional-set #x94 dst ac)] [(sete dst) (conditional-set #x94 dst ac)]
[(setna dst) (conditional-set #x96 dst ac)] [(setna dst) (conditional-set #x96 dst ac)]
[(setnae dst) (conditional-set #x92 dst ac)] [(setnae dst) (conditional-set #x92 dst ac)]
[(setnb dst) (conditional-set #x93 dst ac)] [(setnb dst) (conditional-set #x93 dst ac)]
[(setnbe dst) (conditional-set #x97 dst ac)] [(setnbe dst) (conditional-set #x97 dst ac)]
[(setng dst) (conditional-set #x9E dst ac)] [(setng dst) (conditional-set #x9E dst ac)]
[(setnge dst) (conditional-set #x9C dst ac)] [(setnge dst) (conditional-set #x9C dst ac)]
[(setnl dst) (conditional-set #x9D dst ac)] [(setnl dst) (conditional-set #x9D dst ac)]
[(setnle dst) (conditional-set #x9F dst ac)] [(setnle dst) (conditional-set #x9F dst ac)]
[(setne dst) (conditional-set #x95 dst ac)] [(setne dst) (conditional-set #x95 dst ac)]
[(ja dst) (conditional-jump #x87 dst ac)] [(ja dst) (conditional-jump #x87 dst ac)]
[(jae dst) (conditional-jump #x83 dst ac)] [(jae dst) (conditional-jump #x83 dst ac)]
[(jb dst) (conditional-jump #x82 dst ac)] [(jb dst) (conditional-jump #x82 dst ac)]
[(jbe dst) (conditional-jump #x86 dst ac)] [(jbe dst) (conditional-jump #x86 dst ac)]
[(jg dst) (conditional-jump #x8F dst ac)] [(jg dst) (conditional-jump #x8F dst ac)]
[(jge dst) (conditional-jump #x8D dst ac)] [(jge dst) (conditional-jump #x8D dst ac)]
[(jl dst) (conditional-jump #x8C dst ac)] [(jl dst) (conditional-jump #x8C dst ac)]
[(jle dst) (conditional-jump #x8E dst ac)] [(jle dst) (conditional-jump #x8E dst ac)]
[(je dst) (conditional-jump #x84 dst ac)] [(je dst) (conditional-jump #x84 dst ac)]
[(jna dst) (conditional-jump #x86 dst ac)] [(jna dst) (conditional-jump #x86 dst ac)]
[(jnae dst) (conditional-jump #x82 dst ac)] [(jnae dst) (conditional-jump #x82 dst ac)]
[(jnb dst) (conditional-jump #x83 dst ac)] [(jnb dst) (conditional-jump #x83 dst ac)]
[(jnbe dst) (conditional-jump #x87 dst ac)] [(jnbe dst) (conditional-jump #x87 dst ac)]
[(jng dst) (conditional-jump #x8E dst ac)] [(jng dst) (conditional-jump #x8E dst ac)]
[(jnge dst) (conditional-jump #x8C dst ac)] [(jnge dst) (conditional-jump #x8C dst ac)]
[(jnl dst) (conditional-jump #x8D dst ac)] [(jnl dst) (conditional-jump #x8D dst ac)]
[(jnle dst) (conditional-jump #x8F dst ac)] [(jnle dst) (conditional-jump #x8F dst ac)]
[(jne dst) (conditional-jump #x85 dst ac)] [(jne dst) (conditional-jump #x85 dst ac)]
[(jo dst) (conditional-jump #x80 dst ac)] [(jo dst) (conditional-jump #x80 dst ac)]
[(byte x) [(byte x)
(unless (byte? x) (error who "~s is not a byte" x)) (unless (byte? x) (error who "~s is not a byte" x))
(cons (byte x) ac)] (cons (byte x) ac)]