import from compiler0

This commit is contained in:
Abdulaziz Ghuloum 2006-11-23 19:33:45 -05:00
commit d3313cd737
137 changed files with 126636 additions and 0 deletions

1
.bzrignore Normal file
View File

@ -0,0 +1 @@
*.s

2
src/Makefile Normal file
View File

@ -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

67
src/SuperFastHash.c Normal file
View File

@ -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);
}

655
src/assembler-tests.ss Normal file
View File

@ -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)
)

171
src/assembler.info.ss Normal file
View File

@ -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
)

753
src/assembler.ss Normal file
View File

@ -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))