import from compiler0
This commit is contained in:
commit
d3313cd737
|
@ -0,0 +1 @@
|
|||
*.s
|
|
@ -0,0 +1,2 @@
|
|||
stst: stst.s scheme.c scheme_asm.s runtime-5.4.c collect-5.7.c libtoplevel.s libcxr.s -luuid libsymboltable-5.6.s libhandlers-5.5.s libcontrol-5.8.s libintelasm-5.8.s libcollect-5.3.s librecord-5.6.s libcore-5.7.s libio-5.8.s libwriter-5.7.s libtokenizer-5.7.s libexpand-5.8.s libinterpret-5.8.s libcafe-5.8.s libtrace-5.3.s libposix-5.3.s
|
||||
gcc -Wall -o stst stst.s scheme.c scheme_asm.s runtime-5.4.c collect-5.7.c libtoplevel.s libcxr.s -luuid libsymboltable-5.6.s libhandlers-5.5.s libcontrol-5.8.s libintelasm-5.8.s libcollect-5.3.s librecord-5.6.s libcore-5.7.s libio-5.8.s libwriter-5.7.s libtokenizer-5.7.s libexpand-5.8.s libinterpret-5.8.s libcafe-5.8.s libtrace-5.3.s libposix-5.3.s
|
|
@ -0,0 +1,67 @@
|
|||
#if 0
|
||||
Taken from
|
||||
http://www.azillionmonkeys.com/qed/hash.html
|
||||
|
||||
#endif
|
||||
#include <stdint.h>
|
||||
#include <stdio.h>
|
||||
#undef get16bits
|
||||
#if (defined(__GNUC__) && defined(__i386__)) || defined(__WATCOMC__) \
|
||||
|| defined(_MSC_VER) || defined (__BORLANDC__) || defined (__TURBOC__)
|
||||
#define get16bits(d) (*((const uint16_t *) (d)))
|
||||
#endif
|
||||
|
||||
#if !defined (get16bits)
|
||||
#define get16bits(d) ((((const uint8_t *)(d))[1] << UINT32_C(8))\
|
||||
+((const uint8_t *)(d))[0])
|
||||
#endif
|
||||
|
||||
|
||||
char* SuperFastHash (char* str) {
|
||||
char* data = str + disp_string_data - string_tag;
|
||||
int len = (int) ref(str, disp_string_length - string_tag);
|
||||
len = len >> fx_shift;
|
||||
|
||||
uint32_t hash = len, tmp;
|
||||
int rem;
|
||||
|
||||
if (len <= 0 || data == NULL) return 0;
|
||||
|
||||
rem = len & 3;
|
||||
len >>= 2;
|
||||
|
||||
/* Main loop */
|
||||
for (;len > 0; len--) {
|
||||
hash += get16bits (data);
|
||||
tmp = (get16bits (data+2) << 11) ^ hash;
|
||||
hash = (hash << 16) ^ tmp;
|
||||
data += 2*sizeof (uint16_t);
|
||||
hash += hash >> 11;
|
||||
}
|
||||
|
||||
/* Handle end cases */
|
||||
switch (rem) {
|
||||
case 3: hash += get16bits (data);
|
||||
hash ^= hash << 16;
|
||||
hash ^= data[sizeof (uint16_t)] << 18;
|
||||
hash += hash >> 11;
|
||||
break;
|
||||
case 2: hash += get16bits (data);
|
||||
hash ^= hash << 11;
|
||||
hash += hash >> 17;
|
||||
break;
|
||||
case 1: hash += *data;
|
||||
hash ^= hash << 10;
|
||||
hash += hash >> 1;
|
||||
}
|
||||
|
||||
/* Force "avalanching" of final 127 bits */
|
||||
hash ^= hash << 3;
|
||||
hash += hash >> 5;
|
||||
hash ^= hash << 4;
|
||||
hash += hash >> 17;
|
||||
hash ^= hash << 25;
|
||||
hash += hash >> 6;
|
||||
|
||||
return (char*)(hash<<fx_shift);
|
||||
}
|
|
@ -0,0 +1,655 @@
|
|||
|
||||
(let ()
|
||||
(define verbose #f)
|
||||
(define passed-tests 0)
|
||||
|
||||
(define all-tests 0)
|
||||
|
||||
(define test-code
|
||||
(lambda (code-ls val)
|
||||
(set! all-tests (fxadd1 all-tests))
|
||||
(when verbose (printf "Evaluating\n~s\n" code-ls))
|
||||
(let* ([code (car (#%list*->code* (list code-ls)))]
|
||||
[proc (code->closure code)]
|
||||
[v (proc)])
|
||||
(when verbose (printf "evaluated\n"))
|
||||
(cond
|
||||
[(equal? v val)
|
||||
(set! passed-tests (fxadd1 passed-tests))
|
||||
(when verbose (printf "OK\n"))]
|
||||
[else
|
||||
(error 'test-code
|
||||
"expected ~s, got ~s" val v)]))))
|
||||
|
||||
(test-code
|
||||
'([ret])
|
||||
0)
|
||||
|
||||
(test-code
|
||||
'([movl (int 40) %eax]
|
||||
[ret])
|
||||
10)
|
||||
|
||||
(test-code
|
||||
'([movl (obj 40) %eax]
|
||||
[ret])
|
||||
40)
|
||||
|
||||
(test-code
|
||||
'([movl (obj 40) %ebx]
|
||||
[movl %ebx %eax]
|
||||
[ret])
|
||||
40)
|
||||
|
||||
(test-code
|
||||
'([movl (obj (1 2 3)) %eax]
|
||||
[ret])
|
||||
'(1 2 3))
|
||||
|
||||
(test-code
|
||||
'([movl (obj (1 2 3)) %ebx]
|
||||
[movl (disp (int -1) %ebx) %eax]
|
||||
[ret])
|
||||
'1)
|
||||
|
||||
(test-code
|
||||
'([movl (obj (1 2 3)) %ebx]
|
||||
[movl (disp (int 3) %ebx) %eax]
|
||||
[ret])
|
||||
'(2 3))
|
||||
|
||||
(test-code
|
||||
'([movl (obj (1 2 3)) %ebx]
|
||||
[movl (int 120) %eax]
|
||||
[movl %eax (disp (int 3) %ebx)]
|
||||
[movl %ebx %eax]
|
||||
[ret])
|
||||
'(1 . 30))
|
||||
|
||||
(test-code
|
||||
'([movl (obj (1 2 3)) %eax]
|
||||
[movl (int 120) (disp (int -1) %eax)]
|
||||
[ret])
|
||||
'(30 2 3))
|
||||
|
||||
(test-code
|
||||
'([movl (obj (1 2 3)) %eax]
|
||||
[movl (int 120000) (disp (int -1) %eax)]
|
||||
[ret])
|
||||
'(30000 2 3))
|
||||
|
||||
(test-code
|
||||
'([movl (int 40) %eax]
|
||||
[addl (int 80) %eax]
|
||||
[ret])
|
||||
30)
|
||||
|
||||
(test-code
|
||||
'([movl (int 40) %eax]
|
||||
[addl (obj 20) %eax]
|
||||
[ret])
|
||||
30)
|
||||
|
||||
(test-code
|
||||
'([movl (int 40) %eax]
|
||||
[movl (obj 20) %ebx]
|
||||
[addl %ebx %eax]
|
||||
[ret])
|
||||
30)
|
||||
|
||||
(test-code
|
||||
'([movl (obj (1 2 3)) %eax]
|
||||
[movl (obj 10) %ebx]
|
||||
[addl (disp (int -1) %eax) %ebx]
|
||||
[movl %ebx %eax]
|
||||
[ret])
|
||||
'11)
|
||||
|
||||
(test-code
|
||||
'([movl (obj (1 2 3)) %eax]
|
||||
[addl (int 1000) %eax]
|
||||
[movl (obj 10) %ebx]
|
||||
[addl (disp (int -1001) %eax) %ebx]
|
||||
[movl %ebx %eax]
|
||||
[ret])
|
||||
'11)
|
||||
|
||||
(test-code
|
||||
'([movl (obj 10) %eax]
|
||||
[sall (int 1) %eax]
|
||||
[ret])
|
||||
20)
|
||||
|
||||
|
||||
|
||||
(test-code
|
||||
'([movl (obj 10) %eax]
|
||||
[sall (int 3) %eax]
|
||||
[ret])
|
||||
80)
|
||||
|
||||
(test-code
|
||||
'([movl (obj 10) %eax]
|
||||
[movl (int 3) %ecx]
|
||||
[sall %cl %eax]
|
||||
[ret])
|
||||
80)
|
||||
|
||||
(test-code
|
||||
'([movl (obj #xF0) %eax]
|
||||
[sarl (int 1) %eax]
|
||||
[ret])
|
||||
#x78)
|
||||
|
||||
(test-code
|
||||
'([movl (obj #xF0) %eax]
|
||||
[sarl (int 4) %eax]
|
||||
[ret])
|
||||
#x0F)
|
||||
|
||||
(test-code
|
||||
'([movl (obj #xF0) %eax]
|
||||
[movl (int 4) %ecx]
|
||||
[sarl %cl %eax]
|
||||
[ret])
|
||||
#x0F)
|
||||
|
||||
|
||||
(test-code
|
||||
'([movl (obj #xFFFF) %eax]
|
||||
[andl (obj #xF0F0) %eax]
|
||||
[ret])
|
||||
#xF0F0)
|
||||
|
||||
(test-code
|
||||
'([movl (obj #xFFFF) %eax]
|
||||
[movl (obj #x7654) %ebx]
|
||||
[andl %ebx %eax]
|
||||
[ret])
|
||||
#x7654)
|
||||
|
||||
(test-code
|
||||
'([movl (obj #xFFFF) %eax]
|
||||
[andl (int #x3F) %eax]
|
||||
[ret])
|
||||
#xF)
|
||||
|
||||
(test-code
|
||||
'([movl (obj #xFFFF) %eax]
|
||||
[movl (obj (#xF707F)) %ebx]
|
||||
[andl (disp (int -1) %ebx) %eax]
|
||||
[ret])
|
||||
#x707F)
|
||||
|
||||
(test-code
|
||||
'([movl (obj #xFFFF) %eax]
|
||||
[movl (obj (#xF707F)) %ebx]
|
||||
[addl (int 1000) %ebx]
|
||||
[andl (disp (int -1001) %ebx) %eax]
|
||||
[ret])
|
||||
#x707F)
|
||||
|
||||
(test-code
|
||||
'([movl (int 3) %eax]
|
||||
[notl %eax]
|
||||
[ret])
|
||||
-1)
|
||||
|
||||
(test-code
|
||||
'([movl (obj 1942) %eax]
|
||||
[negl %eax]
|
||||
[ret])
|
||||
-1942)
|
||||
|
||||
(test-code
|
||||
'([movl (obj 10) %eax]
|
||||
[jmp (int 10)]
|
||||
[byte 0]
|
||||
[byte 1]
|
||||
[byte 2]
|
||||
[byte 3]
|
||||
[byte 4]
|
||||
[byte 5]
|
||||
[byte 6]
|
||||
[byte 7]
|
||||
[byte 8]
|
||||
[byte 9]
|
||||
[ret])
|
||||
10)
|
||||
|
||||
(test-code
|
||||
'([movl (obj 10) %eax]
|
||||
[jmp (int 10)]
|
||||
[byte 0]
|
||||
[byte 1]
|
||||
[byte 2]
|
||||
[byte 3]
|
||||
[byte 4]
|
||||
[byte 5]
|
||||
[ret]
|
||||
[byte 7]
|
||||
[byte 8]
|
||||
[byte 9]
|
||||
[jmp (int -9)])
|
||||
10)
|
||||
|
||||
|
||||
|
||||
(let ([L1 (gensym)])
|
||||
(test-code
|
||||
`([movl (obj 10) %eax]
|
||||
[jmp (label ,L1)]
|
||||
[byte 0]
|
||||
[byte 1]
|
||||
[byte 2]
|
||||
[byte 3]
|
||||
[byte 4]
|
||||
[byte 5]
|
||||
[byte 6]
|
||||
[byte 7]
|
||||
[byte 8]
|
||||
[byte 9]
|
||||
[label ,L1]
|
||||
[ret])
|
||||
10))
|
||||
|
||||
(let ([L2 (gensym)]
|
||||
[L3 (gensym)])
|
||||
(test-code
|
||||
`([movl (obj 10) %eax]
|
||||
[jmp (label ,L2)]
|
||||
[byte 0]
|
||||
[byte 1]
|
||||
[byte 2]
|
||||
[byte 3]
|
||||
[byte 4]
|
||||
[byte 5]
|
||||
[label ,L3]
|
||||
[ret]
|
||||
[byte 7]
|
||||
[byte 8]
|
||||
[byte 9]
|
||||
[label ,L2]
|
||||
[jmp (label ,L3)])
|
||||
10))
|
||||
|
||||
|
||||
|
||||
|
||||
(test-code
|
||||
'([movl (obj 10) (disp (int -4) %esp)]
|
||||
[movl (obj list) %eax]
|
||||
[ret])
|
||||
'list)
|
||||
|
||||
(test-code
|
||||
'([movl (obj list) %eax]
|
||||
[movl (disp (int 6) %eax) %eax] ; symbol value
|
||||
[ret])
|
||||
list)
|
||||
|
||||
(test-code
|
||||
'([movl (obj 10) (disp (int -4) %esp)]
|
||||
[movl (obj list) %eax]
|
||||
[movl (disp (int 6) %eax) %edi] ; symbol value
|
||||
[movl (obj -1) %eax] ; argc
|
||||
[jmp (disp (int -3) %edi)])
|
||||
'(10))
|
||||
|
||||
(test-code
|
||||
'([movl (obj 10) (disp (int -4) %esp)]
|
||||
[movl (obj 20) %eax]
|
||||
[movl %eax (disp (int -8) %esp)]
|
||||
[movl (disp (int -8) %esp) %ebx]
|
||||
[movl %ebx (disp (int -12) %esp)]
|
||||
[movl (obj list) %eax]
|
||||
[movl (disp (int 6) %eax) %edi] ; symbol value
|
||||
[movl (obj -3) %eax] ; argc
|
||||
[jmp (disp (int -3) %edi)])
|
||||
'(10 20 20))
|
||||
|
||||
(test-code
|
||||
'([movl (obj 10) %eax]
|
||||
[imull (int 3) %eax]
|
||||
[ret])
|
||||
30)
|
||||
|
||||
(test-code
|
||||
'([movl (obj 10) %eax]
|
||||
[imull (obj 10) %eax]
|
||||
[ret])
|
||||
400)
|
||||
|
||||
(test-code
|
||||
'([movl (obj 10) %eax]
|
||||
[movl (obj 20) %ebx]
|
||||
[imull %ebx %eax]
|
||||
[ret])
|
||||
800)
|
||||
|
||||
(test-code
|
||||
'([movl (obj 10) %eax]
|
||||
[movl (obj 20) (disp (int -4) %esp)]
|
||||
[imull (disp (int -4) %esp) %eax]
|
||||
[ret])
|
||||
800)
|
||||
|
||||
(test-code
|
||||
'([movl (obj 10) %eax]
|
||||
[cltd]
|
||||
[ret])
|
||||
10)
|
||||
|
||||
(test-code
|
||||
'([movl (obj 10) %eax]
|
||||
[movl (obj 100) %edx]
|
||||
[cltd]
|
||||
[movl %edx %eax]
|
||||
[ret])
|
||||
0)
|
||||
|
||||
(test-code
|
||||
'([movl (obj -10) %eax]
|
||||
[movl (obj 100) %edx]
|
||||
[cltd]
|
||||
[movl %edx %eax]
|
||||
[sall (int 2) %eax]
|
||||
[ret])
|
||||
-1)
|
||||
|
||||
(let ([L1 (gensym)])
|
||||
(test-code
|
||||
`([movl (int 10) %eax]
|
||||
[cmpl (int 8) %eax]
|
||||
[jne (label ,L1)]
|
||||
[movl (obj #f) %eax]
|
||||
[ret]
|
||||
[label ,L1]
|
||||
[movl (obj #t) %eax]
|
||||
[ret])
|
||||
#t))
|
||||
|
||||
(let ([L1 (gensym)])
|
||||
(test-code
|
||||
`([movl (int 40) %eax]
|
||||
[cmpl (obj 10) %eax]
|
||||
[je (label ,L1)]
|
||||
[movl (obj #f) %eax]
|
||||
[ret]
|
||||
[label ,L1]
|
||||
[movl (obj #t) %eax]
|
||||
[ret])
|
||||
#t))
|
||||
|
||||
(let ([L1 (gensym)])
|
||||
(test-code
|
||||
`([movl (int 40) %eax]
|
||||
[movl (int 30) %ebx]
|
||||
[cmpl %ebx %eax]
|
||||
[jge (label ,L1)]
|
||||
[movl (obj #f) %eax]
|
||||
[ret]
|
||||
[label ,L1]
|
||||
[movl (obj #t) %eax]
|
||||
[ret])
|
||||
#t))
|
||||
|
||||
(let ([L1 (gensym)])
|
||||
(test-code
|
||||
`([movl (int 40) (disp (int -4) %esp)]
|
||||
[cmpl (int 70) (disp (int -4) %esp)]
|
||||
[jle (label ,L1)]
|
||||
[movl (obj #f) %eax]
|
||||
[ret]
|
||||
[label ,L1]
|
||||
[movl (obj #t) %eax]
|
||||
[ret])
|
||||
#t))
|
||||
|
||||
(test-code
|
||||
'([movl (int 40) (disp (int -4) %esp)]
|
||||
[addl (int 10) %esp]
|
||||
[movl (disp (int -14) %esp) %eax]
|
||||
[addl (int -10) %esp]
|
||||
[ret])
|
||||
10)
|
||||
|
||||
(test-code
|
||||
'([movl (int 40) (disp (int -4) %esp)]
|
||||
[addl (int 1000) %esp]
|
||||
[movl (disp (int -1004) %esp) %eax]
|
||||
[addl (int -1000) %esp]
|
||||
[ret])
|
||||
10)
|
||||
|
||||
(let ([L1 (gensym)])
|
||||
(test-code
|
||||
`([movl (int 40) (disp (int -4) %esp)]
|
||||
[addl (int 1000) %esp]
|
||||
[cmpl (int 70) (disp (int -1004) %esp)]
|
||||
[jle (label ,L1)]
|
||||
[addl (int -1000) %esp]
|
||||
[movl (obj #f) %eax]
|
||||
[ret]
|
||||
[label ,L1]
|
||||
[addl (int -1000) %esp]
|
||||
[movl (obj #t) %eax]
|
||||
[ret])
|
||||
#t))
|
||||
|
||||
(let ([L1 (gensym)])
|
||||
(test-code
|
||||
`([movl (int 4000) (disp (int -4) %esp)]
|
||||
[addl (int 1000) %esp]
|
||||
[cmpl (int 7000) (disp (int -1004) %esp)]
|
||||
[jle (label ,L1)]
|
||||
[addl (int -1000) %esp]
|
||||
[movl (obj #f) %eax]
|
||||
[ret]
|
||||
[label ,L1]
|
||||
[addl (int -1000) %esp]
|
||||
[movl (obj #t) %eax]
|
||||
[ret])
|
||||
#t))
|
||||
|
||||
(let ([L1 (gensym)])
|
||||
(test-code
|
||||
`([movl (int 40) (disp (int -4) %esp)]
|
||||
[movl (int 70) %ebx]
|
||||
[cmpl (disp (int -4) %esp) %ebx]
|
||||
[jge (label ,L1)]
|
||||
[movl (obj #f) %eax]
|
||||
[ret]
|
||||
[label ,L1]
|
||||
[movl (obj #t) %eax]
|
||||
[ret])
|
||||
#t))
|
||||
|
||||
|
||||
(let ([L_fact (gensym)] [L1 (gensym)])
|
||||
(test-code
|
||||
`([movl (int 5) %eax]
|
||||
[call (label ,L_fact)]
|
||||
[sall (int 2) %eax]
|
||||
[ret]
|
||||
[label ,L_fact]
|
||||
[cmpl (int 0) %eax]
|
||||
[jne (label ,L1)]
|
||||
[movl (int 1) %eax]
|
||||
[ret]
|
||||
[label ,L1]
|
||||
[movl %eax (disp (int -4) %esp)]
|
||||
[addl (int -4) %esp]
|
||||
[addl (int -1) %eax]
|
||||
[call (label ,L_fact)]
|
||||
[addl (int 4) %esp]
|
||||
[imull (disp (int -4) %esp) %eax]
|
||||
[ret])
|
||||
120))
|
||||
|
||||
(test-code
|
||||
'([movl (int 16) %eax]
|
||||
[cltd]
|
||||
[movl (int 4) %ebx]
|
||||
[idivl %ebx]
|
||||
[ret])
|
||||
1)
|
||||
|
||||
(test-code
|
||||
'([movl (int 16) %eax]
|
||||
[cltd]
|
||||
[movl (obj (1)) %ebx]
|
||||
[idivl (disp (int -1) %ebx)]
|
||||
[ret])
|
||||
1)
|
||||
|
||||
(test-code
|
||||
'([movl (int 16) %eax]
|
||||
[cltd]
|
||||
[movl (int 4) (disp (int -4) %esp)]
|
||||
[idivl (disp (int -4) %esp)]
|
||||
[ret])
|
||||
1)
|
||||
|
||||
|
||||
(test-code
|
||||
'([movl (int #x30) %ebx]
|
||||
[orl (int #x4) %ebx]
|
||||
[movl %ebx %eax]
|
||||
[ret])
|
||||
(fxsra #x34 2))
|
||||
|
||||
(test-code
|
||||
'([movl (int #x30) %eax]
|
||||
[orl (int #x4) %eax]
|
||||
[ret])
|
||||
(fxsra #x34 2))
|
||||
|
||||
(test-code
|
||||
'([movl (int #x30) %eax]
|
||||
[orl (obj #x1) %eax]
|
||||
[ret])
|
||||
(fxsra #x34 2))
|
||||
|
||||
(test-code
|
||||
'([movl (int #x30) %ebx]
|
||||
[orl (obj #x1) %ebx]
|
||||
[movl %ebx %eax]
|
||||
[ret])
|
||||
(fxsra #x34 2))
|
||||
|
||||
(test-code
|
||||
'([movl (obj (#xC)) %ebx]
|
||||
[movl (int #x4) %eax]
|
||||
[orl (disp (int -1) %ebx) %eax]
|
||||
[ret])
|
||||
(fxsra #x34 2))
|
||||
|
||||
|
||||
(test-code
|
||||
'([movl (int #x30) (disp (int -4) %esp)]
|
||||
[movl (int #x4) %eax]
|
||||
[orl (disp (int -4) %esp) %eax]
|
||||
[ret])
|
||||
(fxsra #x34 2))
|
||||
|
||||
(test-code
|
||||
'([pushl (int 8)]
|
||||
[movl (disp (int 0) %esp) %eax]
|
||||
[addl (int 4) %esp]
|
||||
[ret])
|
||||
2)
|
||||
|
||||
(test-code
|
||||
'([pushl (int 8000)]
|
||||
[movl (disp (int 0) %esp) %eax]
|
||||
[addl (int 4) %esp]
|
||||
[ret])
|
||||
2000)
|
||||
|
||||
(test-code
|
||||
'([movl (int 8000) %ebx]
|
||||
[pushl %ebx]
|
||||
[movl (disp (int 0) %esp) %eax]
|
||||
[addl (int 4) %esp]
|
||||
[ret])
|
||||
2000)
|
||||
|
||||
(test-code
|
||||
'([movl (obj (1 2 3)) %eax]
|
||||
[pushl (disp (int 3) %eax)]
|
||||
[addl (int 4) %esp]
|
||||
[movl (disp (int -4) %esp) %eax]
|
||||
[ret])
|
||||
'(2 3))
|
||||
|
||||
(test-code
|
||||
'([movl (obj (1 2 3)) %eax]
|
||||
[addl (int -1000) %eax]
|
||||
[pushl (disp (int 1003) %eax)]
|
||||
[addl (int 4) %esp]
|
||||
[movl (disp (int -4) %esp) %eax]
|
||||
[ret])
|
||||
'(2 3))
|
||||
|
||||
(test-code
|
||||
'([pushl (obj 100)]
|
||||
[popl %eax]
|
||||
[ret])
|
||||
100)
|
||||
|
||||
(test-code
|
||||
'([pushl (obj 100)]
|
||||
[popl (disp (int -32) %esp)]
|
||||
[movl (disp (int -32) %esp) %eax]
|
||||
[ret])
|
||||
100)
|
||||
|
||||
(test-code
|
||||
'([movl (int 4) %eax]
|
||||
[cmpl (int 5) %eax]
|
||||
[sete %al]
|
||||
[andl (int 1) %eax]
|
||||
[sall (int 2) %eax]
|
||||
[ret])
|
||||
0)
|
||||
|
||||
(test-code
|
||||
'([movl (int 4) %eax]
|
||||
[cmpl (int 5) %eax]
|
||||
[setle %al]
|
||||
[andl (int 1) %eax]
|
||||
[sall (int 2) %eax]
|
||||
[ret])
|
||||
1)
|
||||
|
||||
(test-code
|
||||
'([movl (obj+ (1 2 3) 3) %eax]
|
||||
[movl (disp (int 0) %eax) %eax]
|
||||
[ret])
|
||||
'(2 3))
|
||||
|
||||
(let ([L_entry (gensym)] [L_no (gensym)])
|
||||
(test-code
|
||||
`([movl (obj 10) %eax]
|
||||
[ret]
|
||||
[label ,L_entry]
|
||||
[cmpl (int 1) %eax]
|
||||
[jne (label ,L_no)]
|
||||
[movl (obj foo) %eax]
|
||||
[ret]
|
||||
[label ,L_no]
|
||||
[movl (obj bar) %eax]
|
||||
[ret])
|
||||
10)
|
||||
(test-code
|
||||
`([movl (int 1) %eax]
|
||||
[jmp (label ,L_entry)])
|
||||
'foo)
|
||||
(test-code
|
||||
`([movl (int 0) %eax]
|
||||
[jmp (label ,L_entry)])
|
||||
'bar))
|
||||
|
||||
(printf "Passed ~s/~s tests in assembler\n" passed-tests all-tests)
|
||||
)
|
|
@ -0,0 +1,171 @@
|
|||
|
||||
;;; Instruction format:
|
||||
;;; 0,1,2,3,4 byte prefixes
|
||||
;;; 1,2,3 byte opcode
|
||||
;;; 0,1 byte ModR/M
|
||||
;;; 0,1 byte SIB
|
||||
;;; 0,1,2,4 bytes address displacement
|
||||
;;; 0,1,2,4 bytes immediate
|
||||
;;;
|
||||
;;; Prefixes:
|
||||
;;; 0 to 4 prefixes are permitted. Up to one prefix from each of the
|
||||
;;; following groups is permitted (in any order)
|
||||
;;; Group 1: Lock and Repeat
|
||||
;;; 0xF0 -- LOCK
|
||||
;;; 0xF2 -- REPNE/REPNZ (for string instructions)
|
||||
;;; 0xF3 -- REPE/REPX (for string instructions)
|
||||
;;; Group 2: Segment override and branch hints
|
||||
;;; 0x2E -- CS segment override
|
||||
;;; 0x36 -- SS
|
||||
;;; 0x3E -- DS
|
||||
;;; 0x26 -- ES
|
||||
;;; 0x64 -- FS
|
||||
;;; 0x65 -- GS
|
||||
;;; Group 3:
|
||||
;;; 0x66 -- Operand-size override
|
||||
;;; Group 4:
|
||||
;;; 0x67 -- Address-size override
|
||||
;;;
|
||||
;;; Opcodes:
|
||||
;;; * Either 1 byte opcode
|
||||
;;; * Or 2-bytes formed by 0x0F escape opcode followed by a second opcode
|
||||
;;; * Or 3-bytes formed by 0x66,0xF2,0xF3 prefix followed by escape opcode,
|
||||
;;; then a second opcode
|
||||
;;;
|
||||
;;; Mod/RM: 1 byte
|
||||
;;; ._________._____________.___________.
|
||||
;;; Bits: | 7 6 | 5 4 3 | 2 1 0 |
|
||||
;;; | mod | reg/opcode | R/M |
|
||||
;;; `~~~~~~~~~^~~~~~~~~~~~~~^~~~~~~~~~~~'
|
||||
;;; Refer to table 2-2 Page 39 from IA32 Vol2A instruction set reference
|
||||
;;;
|
||||
;;; Mod:
|
||||
;;; 0b00 -- direct dereference (i.e. [EAX], [ECX], ... , sib, disp32)
|
||||
;;; 0b01 -- deref + 8-bit disp (i.e. [EAX]+disp8, ...)
|
||||
;;; 0b10 -- deref + 32-bit disp
|
||||
;;; 0b11 -- register name (i.e. EAX, ECX, ...)
|
||||
;;;
|
||||
;;; R/M: In general, the register names are as follows:
|
||||
;;; 0b000 -- eax
|
||||
;;; 0b001 -- ecx
|
||||
;;; 0b010 -- edx
|
||||
;;; 0b011 -- ebx
|
||||
;;; 0b100 -- esp
|
||||
;;; 0b101 -- ebp
|
||||
;;; 0b110 -- esi
|
||||
;;; 0b111 -- edi
|
||||
;;; Exceptions:
|
||||
;;; If mod is 0b00, 0b01 or 0b10:
|
||||
;;; then esp is invalid and 0b100 is used to denote the presence
|
||||
;;; of an SIB field
|
||||
;;; If mod is 0b00:
|
||||
;;; then ebp is invalid and 0b101 is used to denote a disp32 field
|
||||
;;; that follows the Mod/RM byte and (or the SIB byte if present).
|
||||
;;;
|
||||
;;; /r: The /r denoted the register operand, the numbers are the same
|
||||
;;; as above.
|
||||
;;;
|
||||
;;;
|
||||
;;; SIB: 1 byte
|
||||
;;; ._________._____________.___________.
|
||||
;;; Bits: | 7 6 | 5 4 3 | 2 1 0 |
|
||||
;;; | scale | index | base |
|
||||
;;; `~~~~~~~~~^~~~~~~~~~~~~~^~~~~~~~~~~~'
|
||||
;;; Refer to table 2-3 Page 40 from IA32 Vol2A instruction set reference
|
||||
;;;
|
||||
;;; Scale:
|
||||
;;; 0b00: multiply index register by 1 (no scale)
|
||||
;;; 0b01: multiply index register by 2
|
||||
;;; 0b10: multiply index register by 4
|
||||
;;; 0b11: multiply index register by 8
|
||||
;;;
|
||||
;;; Index: a register number
|
||||
;;; (esp or 0b100 is invalid as an index)
|
||||
;;;
|
||||
;;; Base: a register number
|
||||
;;; ebp or 0b101 as a base is interpreted as follows:
|
||||
;;; If mod == 0b00, then EA = scaled index + disp32 (no base)
|
||||
;;; If mod == 0b01, then EA = scaled index + disp8 + ebp
|
||||
;;; If mod == 0b10, then EA = scaled index + disp32 + ebp
|
||||
;;; If mod == 0b11, then I DON'T KNOW
|
||||
;;;
|
||||
;;;
|
||||
;;;
|
||||
|
||||
|
||||
(define-instr (TMPL1 primary secondary d s)
|
||||
(cases (d s)
|
||||
[(AL imm8) => (logor primary #b00000100) s] ; 04 ib
|
||||
[(EAX imm32) => (logor primary #b00000101) s] ; 05 id
|
||||
[(reg/mem8 imm8) => #b10000000 secondary ib] ; 80 /0 ib
|
||||
[(reg/mem32 imm32) => #b10000001 secondary id] ; 81 /0 id
|
||||
[(reg/mem32 imm8) => #b10000011 secondary ib] ; 83 /0 ib (sign ext.)
|
||||
[(reg/mem8 reg8) => (logor primary #b00000000) /r ] ; 00 /r
|
||||
[(reg/mem32 reg32) => (logor primary #b00000001) /r ] ; 01 /r
|
||||
[(reg8 reg/mem8) => (logor primary #b00000010) /r ] ; 02 /r
|
||||
[(reg32 reg/mem32) => (logor primary #b00000011) /r ] ; 03 /r
|
||||
))
|
||||
|
||||
(define-insrt (ADD d s) (TMPL1 #b00000000 /0 d s))
|
||||
|
||||
(define-insrt (AND d s) (TMPL1 #b00100000 /4 d s))
|
||||
|
||||
(define-instr (CMP d s) (TMPL1 #b00111000 /7 d s))
|
||||
|
||||
(define-insrt (CALL d)
|
||||
(cases (d)
|
||||
[(rel32of) => #b11101000 id] ; E8 id
|
||||
[(reg/mem32) => #b11111111 /2] ; FF /2
|
||||
))
|
||||
|
||||
(define-instr (CLTD) ; convert long to double
|
||||
(cases ()
|
||||
[() => #b10011001] ; 99
|
||||
))
|
||||
|
||||
(define-insrt (IDIV s)
|
||||
(cases (s)
|
||||
[(reg/mem8) => #b11110110 /7] ; F6 /7
|
||||
[(reg/mem32) => #b11110111 /7] ; F7 /7
|
||||
))
|
||||
|
||||
imull
|
||||
ja
|
||||
jae
|
||||
jb
|
||||
jbe
|
||||
je
|
||||
jg
|
||||
jge
|
||||
jl
|
||||
jle
|
||||
jmp
|
||||
jne
|
||||
movb
|
||||
movl
|
||||
movswl
|
||||
movzbl
|
||||
negl
|
||||
notl
|
||||
orl
|
||||
pop
|
||||
popl
|
||||
push
|
||||
pushl
|
||||
ret
|
||||
sall
|
||||
sarl
|
||||
sete
|
||||
setg
|
||||
setge
|
||||
setl
|
||||
setle
|
||||
shll
|
||||
shrl
|
||||
subl
|
||||
xorl
|
||||
|
||||
|
||||
)
|
||||
|
||||
|
|
@ -0,0 +1,753 @@
|
|||
|
||||
;;; add
|
||||
;;; and
|
||||
;;; cmp
|
||||
;;; call
|
||||
;;; cltd
|
||||
;;; idiv
|
||||
;;; imull
|
||||
;;; ja
|
||||
;;; jae
|
||||
;;; jb
|
||||
;;; jbe
|
||||
;;; je
|
||||
;;; jg
|
||||
;;; jge
|
||||
;;; jl
|
||||
;;; jle
|
||||
;;; jne
|
||||
;;; jmp
|
||||
;;; movb
|
||||
;;; movl
|
||||
;;; negl
|
||||
;;; notl
|
||||
;;; orl
|
||||
;;; popl
|
||||
;;; pushl
|
||||
;;; ret
|
||||
;;; sall
|
||||
;;; sarl
|
||||
;;; sete
|
||||
;;; setg
|
||||
|
||||
|
||||
(let ()
|
||||
|
||||
(define fold
|
||||
(lambda (f init ls)
|
||||
(cond
|
||||
[(null? ls) init]
|
||||
[else
|
||||
(f (car ls) (fold f init (cdr ls)))])))
|
||||
|
||||
(define convert-instructions
|
||||
(lambda (ls)
|
||||
(fold convert-instruction '() ls)))
|
||||
|
||||
(define register-mapping
|
||||
'([%eax 32 0]
|
||||
[%ecx 32 1]
|
||||
[%edx 32 2]
|
||||
[%ebx 32 3]
|
||||
[%esp 32 4]
|
||||
[%ebp 32 5]
|
||||
[%esi 32 6]
|
||||
[%edi 32 7]
|
||||
[%al 8 0]
|
||||
[%cl 8 1]
|
||||
[%dl 8 2]
|
||||
[%bl 8 3]
|
||||
[%ah 8 4]
|
||||
[%ch 8 5]
|
||||
[%dh 8 6]
|
||||
[%bh 8 7]
|
||||
[/0 0 0]
|
||||
[/1 0 1]
|
||||
[/2 0 2]
|
||||
[/3 0 3]
|
||||
[/4 0 4]
|
||||
[/5 0 5]
|
||||
[/6 0 6]
|
||||
[/7 0 7]
|
||||
))
|
||||
|
||||
(define register-index
|
||||
(lambda (x)
|
||||
(cond
|
||||
[(assq x register-mapping) => caddr]
|
||||
[else (error 'register-index "not a register ~s" x)])))
|
||||
|
||||
(define reg32?
|
||||
(lambda (x)
|
||||
(cond
|
||||
[(assq x register-mapping) =>
|
||||
(lambda (x) (fx= (cadr x) 32))]
|
||||
[else #f])))
|
||||
|
||||
(define reg8?
|
||||
(lambda (x)
|
||||
(cond
|
||||
[(assq x register-mapping) =>
|
||||
(lambda (x) (fx= (cadr x) 8))]
|
||||
[else #f])))
|
||||
|
||||
(define reg?
|
||||
(lambda (x)
|
||||
(assq x register-mapping)))
|
||||
|
||||
(define check-len
|
||||
(lambda (x)
|
||||
(define instr-len
|
||||
'([ret]
|
||||
[movl s d]
|
||||
[addl s d]
|
||||
[sall s d]
|
||||
[sarl s d]
|
||||
[andl s d]
|
||||
[orl s d]
|
||||
[cmpl s d]
|
||||
[imull s d]
|
||||
[notl d]
|
||||
[negl d]
|
||||
[idivl d]
|
||||
[pushl d]
|
||||
[popl d]
|
||||
[jmp d]
|
||||
[call d]
|
||||
[ja d]
|
||||
[jae d]
|
||||
[jb d]
|
||||
[jbe d]
|
||||
[je d]
|
||||
[jg d]
|
||||
[jge d]
|
||||
[jl d]
|
||||
[jle d]
|
||||
[jna d]
|
||||
[jnae d]
|
||||
[jnb d]
|
||||
[jnbe d]
|
||||
[jne d]
|
||||
[jng d]
|
||||
[jnge d]
|
||||
[jnl d]
|
||||
[jnle d]
|
||||
[seta d]
|
||||
[setae d]
|
||||
[setb d]
|
||||
[setbe d]
|
||||
[sete d]
|
||||
[setg d]
|
||||
[setge d]
|
||||
[setl d]
|
||||
[setle d]
|
||||
[setna d]
|
||||
[setnae d]
|
||||
[setnb d]
|
||||
[setnbe d]
|
||||
[setne d]
|
||||
[setng d]
|
||||
[setnge d]
|
||||
[setnl d]
|
||||
[setnle d]
|
||||
[cltd]
|
||||
[byte x]
|
||||
[label x]
|
||||
))
|
||||
(cond
|
||||
[(assq (car x) instr-len) =>
|
||||
(lambda (p)
|
||||
(unless (fx= (length x) (length p))
|
||||
(error 'check-len "invalid instruction format ~s" x)))]
|
||||
[else (error 'check-len "unknown instruction ~s" x)])))
|
||||
|
||||
(define with-args
|
||||
(lambda (ls f)
|
||||
(apply f (cdr ls))))
|
||||
|
||||
(define byte
|
||||
(lambda (x)
|
||||
(cons 'byte (fxlogand x 255))))
|
||||
|
||||
|
||||
(define word
|
||||
(lambda (x)
|
||||
(cons 'word x)))
|
||||
|
||||
(define reloc-word
|
||||
(lambda (x)
|
||||
(cons 'reloc-word x)))
|
||||
|
||||
(define reloc-word+
|
||||
(lambda (x d)
|
||||
(list* 'reloc-word+ x d)))
|
||||
|
||||
(define list*-aux
|
||||
(lambda (ls ls*)
|
||||
(cond
|
||||
[(null? ls*) ls]
|
||||
[else (cons ls (list*-aux (car ls*) (cdr ls*)))])))
|
||||
|
||||
(define list*
|
||||
(lambda (ls . ls*)
|
||||
(list*-aux ls ls*)))
|
||||
|
||||
(define byte?
|
||||
(lambda (x)
|
||||
(and (fixnum? x)
|
||||
(fx<= x 127)
|
||||
(fx<= -128 x))))
|
||||
|
||||
(define mem?
|
||||
(lambda (x)
|
||||
(and (list? x)
|
||||
(fx= (length x) 3)
|
||||
(eq? (car x) 'disp)
|
||||
(imm? (cadr x))
|
||||
(reg? (caddr x)))))
|
||||
|
||||
(define small-disp?
|
||||
(lambda (x)
|
||||
(and (mem? x)
|
||||
(byte? (cadr x)))))
|
||||
|
||||
|
||||
(define CODE
|
||||
(lambda (n ac)
|
||||
(cons (byte n) ac)))
|
||||
|
||||
(define CODE+r
|
||||
(lambda (n r ac)
|
||||
(cons (byte (fxlogor n (register-index r))) ac)))
|
||||
|
||||
(define ModRM
|
||||
(lambda (mod reg r/m ac)
|
||||
(cons (byte (fxlogor
|
||||
(register-index r/m)
|
||||
(fxlogor
|
||||
(fxsll (register-index reg) 3)
|
||||
(fxsll mod 6))))
|
||||
(if (and (not (fx= mod 3)) (eq? r/m '%esp))
|
||||
(cons (byte #x24) ac)
|
||||
ac))))
|
||||
|
||||
(define IMM32
|
||||
(lambda (n ac)
|
||||
(cond
|
||||
[(int? n)
|
||||
(let ([n (cadr n)])
|
||||
(list* (byte n)
|
||||
(byte (fxsra n 8))
|
||||
(byte (fxsra n 16))
|
||||
(byte (fxsra n 24))
|
||||
ac))]
|
||||
[(obj? n)
|
||||
(let ([v (cadr n)])
|
||||
(if (immediate? v)
|
||||
(cons (word v) ac)
|
||||
(cons (reloc-word v) ac)))]
|
||||
[(obj+? n)
|
||||
(let ([v (cadr n)] [d (caddr n)])
|
||||
(cons (reloc-word+ v d) ac))]
|
||||
[else (error 'IMM32 "invalid ~s" n)])))
|
||||
|
||||
|
||||
(define IMM8
|
||||
(lambda (n ac)
|
||||
(cond
|
||||
[(int? n)
|
||||
(let ([n (cadr n)])
|
||||
(list* (byte n) ac))]
|
||||
[else (error 'IMM8 "invalid ~s" n)])))
|
||||
|
||||
|
||||
(define imm?
|
||||
(lambda (x)
|
||||
(or (int? x) (obj? x) (obj+? x))))
|
||||
|
||||
(define imm8?
|
||||
(lambda (x)
|
||||
(and (int? x) (byte? (cadr x)))))
|
||||
|
||||
(define label?
|
||||
(lambda (x)
|
||||
(cond
|
||||
[(and (pair? x) (eq? (car x) 'label))
|
||||
(let ([d (cdr x)])
|
||||
(unless (and (null? (cdr d))
|
||||
(symbol? (car d)))
|
||||
(error #f "invalid label ~s" x)))
|
||||
#t]
|
||||
[else #f])))
|
||||
|
||||
(define label-name
|
||||
(lambda (x) (cadr x)))
|
||||
|
||||
(define int?
|
||||
(lambda (x)
|
||||
(and (pair? x) (eq? (car x) 'int))))
|
||||
|
||||
(define obj?
|
||||
(lambda (x)
|
||||
(and (pair? x) (eq? (car x) 'obj))))
|
||||
|
||||
(define obj+?
|
||||
(lambda (x)
|
||||
(and (pair? x) (eq? (car x) 'obj+))))
|
||||
|
||||
(define CODErri
|
||||
(lambda (c d s i ac)
|
||||
(cond
|
||||
[(imm8? i)
|
||||
(CODE c (ModRM 1 d s (IMM8 i ac)))]
|
||||
[else
|
||||
(CODE c (ModRM 2 d s (IMM32 i ac)))])))
|
||||
|
||||
(define CODErr
|
||||
(lambda (c d s ac)
|
||||
(CODE c (ModRM 3 d s ac))))
|
||||
|
||||
(define CODEri
|
||||
(lambda (c d i ac)
|
||||
(CODE+r c d (IMM32 i ac))))
|
||||
|
||||
(define CODErd
|
||||
(lambda (c r1 disp ac)
|
||||
(with-args disp
|
||||
(lambda (i r2)
|
||||
(CODErri c r1 r2 i ac)))))
|
||||
|
||||
(define CODEdi
|
||||
(lambda (c disp n ac)
|
||||
(with-args disp
|
||||
(lambda (i r)
|
||||
(CODErri c '/0 r i (IMM32 n ac))))))
|
||||
|
||||
(define convert-instruction
|
||||
(lambda (a ac)
|
||||
(define who 'assemble)
|
||||
(check-len a)
|
||||
(case (car a)
|
||||
[(ret) (CODE #xC3 ac)]
|
||||
[(cltd) (CODE #x99 ac)]
|
||||
[(movl)
|
||||
(with-args a
|
||||
(lambda (src dst)
|
||||
(cond
|
||||
[(and (imm? src) (reg? dst)) (CODEri #xB8 dst src ac)]
|
||||
[(and (imm? src) (mem? dst)) (CODEdi #xC7 dst src ac)]
|
||||
[(and (reg? src) (reg? dst)) (CODErr #x89 src dst ac)]
|
||||
[(and (reg? src) (mem? dst)) (CODErd #x89 src dst ac)]
|
||||
[(and (mem? src) (reg? dst)) (CODErd #x8B dst src ac)]
|
||||
[else (error who "invalid ~s" a)])))]
|
||||
[(movb)
|
||||
(with-args a
|
||||
(lambda (src dst)
|
||||
(cond
|
||||
[(and (imm8? src) (reg8? dst)) (CODEri #xB0 dst src ac)]
|
||||
[(and (imm8? src) (mem? dst)) (CODEdi #xC6 dst src ac)]
|
||||
[(and (reg8? src) (reg8? dst)) (CODErr #x88 src dst ac)]
|
||||
[(and (reg8? src) (mem? dst)) (CODErd #x88 src dst ac)]
|
||||
[(and (mem? src) (reg8? dst)) (CODErd #x8A dst src ac)]
|
||||
[else (error who "invalid ~s" a)])))]
|
||||
[(addl)
|
||||
(with-args a
|
||||
(lambda (src dst)
|
||||
(cond
|
||||
;;; add imm -> reg
|
||||
[(and (imm8? src) (reg? dst))
|
||||
(CODE #x83 (ModRM 3 '/0 dst (IMM8 src ac)))]
|
||||
[(and (imm? src) (eq? dst '%eax))
|
||||
(CODE #x05 (IMM32 src ac))]
|
||||
[(and (imm? src) (reg? dst))
|
||||
(CODE #x81 (ModRM 3 '/0 dst (IMM32 src ac)))]
|
||||
;;; add reg -> reg
|
||||
[(and (reg? src) (reg? dst))
|
||||
(CODE #x01 (ModRM 3 src dst ac))]
|
||||
;;; add mem -> reg
|
||||
[(and (mem? src) (reg? dst))
|
||||
(CODErd #x03 dst src ac)]
|
||||
;;; add imm -> mem (not needed)
|
||||
;;; add reg -> mem (not needed)
|
||||
[else (error who "invalid ~s" a)])))]
|
||||
[(sall)
|
||||
(with-args a
|
||||
(lambda (src dst)
|
||||
(cond
|
||||
[(and (equal? '(int 1) src) (reg? dst))
|
||||
(CODE #xD1 (ModRM 3 '/4 dst ac))]
|
||||
[(and (imm8? src) (reg? dst))
|
||||
(CODE #xC1 (ModRM 3 '/4 dst (IMM8 src ac)))]
|
||||
[(and (eq? src '%cl) (reg? dst))
|
||||
(CODE #xD3 (ModRM 3 '/4 dst ac))]
|
||||
[else (error who "invalid ~s" a)])))]
|
||||
[(sarl)
|
||||
(with-args a
|
||||
(lambda (src dst)
|
||||
(cond
|
||||
[(and (equal? '(int 1) src) (reg? dst))
|
||||
(CODE #xD1 (ModRM 3 '/7 dst ac))]
|
||||
[(and (imm8? src) (reg? dst))
|
||||
(CODE #xC1 (ModRM 3 '/7 dst (IMM8 src ac)))]
|
||||
[(and (eq? src '%cl) (reg? dst))
|
||||
(CODE #xD3 (ModRM 3 '/7 dst ac))]
|
||||
[else (error who "invalid ~s" a)])))]
|
||||
[(andl) ; similar to add
|
||||
(with-args a
|
||||
(lambda (src dst)
|
||||
(cond
|
||||
;;; and imm -> reg
|
||||
[(and (imm8? src) (reg? dst))
|
||||
(CODE #x83 (ModRM 3 '/4 dst (IMM8 src ac)))]
|
||||
[(and (imm? src) (eq? dst '%eax))
|
||||
(CODE #x25 (IMM32 src ac))]
|
||||
[(and (imm? src) (reg? dst))
|
||||
(CODE #x81 (ModRM 3 '/4 dst (IMM32 src ac)))]
|
||||
;;; and reg -> reg
|
||||
[(and (reg? src) (reg? dst))
|
||||
(CODE #x21 (ModRM 3 src dst ac))]
|
||||
;;; and mem -> reg
|
||||
[(and (mem? src) (reg? dst))
|
||||
(CODErd #x23 dst src ac)]
|
||||
[else (error who "invalid ~s" a)])))]
|
||||
[(orl) ; similar to add
|
||||
(with-args a
|
||||
(lambda (src dst)
|
||||
(cond
|
||||
;;; or imm -> reg
|
||||
[(and (imm8? src) (reg? dst))
|
||||
(CODE #x83 (ModRM 3 '/1 dst (IMM8 src ac)))]
|
||||
[(and (imm? src) (eq? dst '%eax))
|
||||
(CODE #x0D (IMM32 src ac))]
|
||||
[(and (imm? src) (reg? dst))
|
||||
(CODE #x81 (ModRM 3 '/1 dst (IMM32 src ac)))]
|
||||
;;; or reg -> reg
|
||||
[(and (reg? src) (reg? dst))
|
||||
(CODE #x09 (ModRM 3 src dst ac))]
|
||||
;;; or mem -> reg
|
||||
[(and (mem? src) (reg? dst))
|
||||
(CODErd #x0B dst src ac)]
|
||||
[else (error who "invalid ~s" a)])))]
|
||||
[(cmpl)
|
||||
(with-args a
|
||||
(lambda (src dst)
|
||||
(cond
|
||||
[(and (imm8? src) (reg? dst))
|
||||
(CODE #x83 (ModRM 3 '/7 dst (IMM8 src ac)))]
|
||||
[(and (imm? src) (eq? dst '%eax))
|
||||
(CODE #x3D (IMM32 src ac))]
|
||||
[(and (reg? src) (reg? dst))
|
||||
(CODE #x39 (ModRM 3 src dst ac))]
|
||||
[(and (mem? src) (reg? dst))
|
||||
(CODErd #x3B dst src ac)]
|
||||
[(and (imm8? src) (mem? dst))
|
||||
(CODErd #x83 '/7 dst (IMM8 src ac))]
|
||||
[(and (imm? src) (mem? dst))
|
||||
(CODErd #x81 '/7 dst (IMM32 src ac))]
|
||||
[else (error who "invalid ~s" a)])))]
|
||||
[(imull)
|
||||
(with-args a
|
||||
(lambda (src dst)
|
||||
(cond
|
||||
[(and (imm8? src) (reg? dst))
|
||||
(CODE #x6B (ModRM 3 dst dst (IMM8 src ac)))]
|
||||
[(and (imm? src) (reg? dst))
|
||||
(CODE #x69 (ModRM 3 dst dst (IMM32 src ac)))]
|
||||
[(and (reg? src) (reg? dst))
|
||||
(CODE #x0F (CODE #xAF (ModRM 3 dst src ac)))]
|
||||
[(and (mem? src) (reg? dst))
|
||||
(CODE #x0F (CODErd #xAF dst src ac))]
|
||||
[else (error who "invalid ~s" a)])))]
|
||||
[(idivl)
|
||||
(with-args a
|
||||
(lambda (dst)
|
||||
(cond
|
||||
[(reg? dst)
|
||||
(CODErr #xF7 '/7 dst ac)]
|
||||
[(mem? dst)
|
||||
(CODErd #xF7 '/7 dst ac)]
|
||||
[else (error who "invalid ~s" a)])))]
|
||||
[(pushl)
|
||||
(with-args a
|
||||
(lambda (dst)
|
||||
(cond
|
||||
[(imm8? dst)
|
||||
(CODE #x6A (IMM8 dst ac))]
|
||||
[(imm? dst)
|
||||
(CODE #x68 (IMM32 dst ac))]
|
||||
[(reg? dst)
|
||||
(CODE+r #x50 dst ac)]
|
||||
[(mem? dst)
|
||||
(CODErd #xFF '/6 dst ac)]
|
||||
[else (error who "invalid ~s" a)])))]
|
||||
[(popl)
|
||||
(with-args a
|
||||
(lambda (dst)
|
||||
(cond
|
||||
[(reg? dst)
|
||||
(CODE+r #x58 dst ac)]
|
||||
[(mem? dst)
|
||||
(CODErd #x8F '/0 dst ac)]
|
||||
[else (error who "invalid ~s" a)])))]
|
||||
[(notl)
|
||||
(with-args a
|
||||
(lambda (dst)
|
||||
(cond
|
||||
[(reg? dst)
|
||||
(CODE #xF7 (ModRM 3 '/2 dst ac))]
|
||||
[(mem? dst)
|
||||
(CODErd #xF7 '/7 dst ac)]
|
||||
[else (error who "invalid ~s" a)])))]
|
||||
[(negl)
|
||||
(with-args a
|
||||
(lambda (dst)
|
||||
(cond
|
||||
[(reg? dst)
|
||||
(CODE #xF7 (ModRM 3 '/3 dst ac))]
|
||||
[else (error who "invalid ~s" a)])))]
|
||||
[(jmp)
|
||||
(with-args a
|
||||
(lambda (dst)
|
||||
(cond
|
||||
[(label? dst)
|
||||
(CODE #xE9 (cons (cons 'relative (label-name dst)) ac))]
|
||||
[(imm? dst)
|
||||
(CODE #xE9 (IMM32 dst ac))]
|
||||
[(mem? dst)
|
||||
(CODErd #xFF '/4 dst ac)]
|
||||
[else (error who "invalid jmp in ~s" a)])))]
|
||||
[(call)
|
||||
(with-args a
|
||||
(lambda (dst)
|
||||
(cond
|
||||
[(imm? dst)
|
||||
(CODE #xE8 (IMM32 dst ac))]
|
||||
[(label? dst)
|
||||
(CODE #xE8 (cons (cons 'relative (label-name dst)) ac))]
|
||||
[(mem? dst)
|
||||
(CODErd #xFF '/2 dst ac)]
|
||||
[else (error who "invalid jmp in ~s" a)])))]
|
||||
[(seta setae setb setbe sete setg setge setl setle
|
||||
setna setnae setnb setnbe setne setng setnge setnl setnle)
|
||||
(let* ([table
|
||||
'([seta #x97] [setna #x96]
|
||||
[setae #x93] [setnae #x92]
|
||||
[setb #x92] [setnb #x93]
|
||||
[setbe #x96] [setnbe #x97]
|
||||
[setg #x9F] [setng #x9E]
|
||||
[setge #x9D] [setnge #x9C]
|
||||
[setl #x9C] [setnl #x9D]
|
||||
[setle #x9E] [setnle #x9F]
|
||||
[sete #x94] [setne #x95])]
|
||||
[lookup
|
||||
(lambda (x)
|
||||
(cond
|
||||
[(assq x table) => cadr]
|
||||
[else (error who "invalid cset ~s" x)]))])
|
||||
(with-args a
|
||||
(lambda (dst)
|
||||
(cond
|
||||
[(reg8? dst)
|
||||
(CODE #x0F
|
||||
(CODE (lookup (car a))
|
||||
(ModRM 3 '/0 dst ac)))]
|
||||
[else (error who "invalid ~s" a)]))))]
|
||||
[(ja jae jb jbe je jg jge jl jle
|
||||
jna jnae jnb jnbe jne jng jnge jnl jnle)
|
||||
(let* ([table
|
||||
'([je #x84] [jne #x85]
|
||||
[ja #x87] [jna #x86]
|
||||
[jae #x83] [jnae #x82]
|
||||
[jb #x82] [jnb #x83]
|
||||
[jbe #x86] [jnbe #x87]
|
||||
[jg #x8F] [jng #x8E]
|
||||
[jge #x8D] [jnge #x8C]
|
||||
[jl #x8C] [jnl #x8D]
|
||||
[jle #x8E] [jnle #x8F])]
|
||||
[lookup
|
||||
(lambda (x)
|
||||
(cond
|
||||
[(assq x table) => cadr]
|
||||
[else (error who "invalid cmp ~s" x)]))])
|
||||
(with-args a
|
||||
(lambda (dst)
|
||||
(cond
|
||||
[(imm? dst)
|
||||
(CODE #x0F (CODE (lookup (car a)) (IMM32 dst ac)))]
|
||||
[(label? dst)
|
||||
(CODE #x0F
|
||||
(CODE (lookup (car a))
|
||||
(cons (cons 'relative (label-name dst)) ac)))]
|
||||
[else (error who "invalid ~s" a)]))))]
|
||||
[(byte)
|
||||
(with-args a
|
||||
(lambda (x)
|
||||
(unless (byte? x) (error who "invalid instruction ~s" a))
|
||||
(cons (byte x) ac)))]
|
||||
[(label)
|
||||
(with-args a
|
||||
(lambda (L)
|
||||
(unless (symbol? L) (error who "invalid instruction ~s" a))
|
||||
(cons (cons 'label L) ac)))]
|
||||
[else
|
||||
(error who "unknown instruction ~s" a)])))
|
||||
|
||||
(define diff
|
||||
(lambda (ls x)
|
||||
(cond
|
||||
[(eq? ls x) '()]
|
||||
[else (cons (car ls) (diff (cdr ls) x))])))
|
||||
|
||||
(define hex-table
|
||||
'#(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7
|
||||
#\8 #\9 #\A #\B #\C #\D #\E #\F))
|
||||
|
||||