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

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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))
(define write/x
(lambda (x)
(case (car x)
[(byte)
(display "0x")
(display (vector-ref hex-table (fxsra (cdr x) 4)))
(display (vector-ref hex-table (fxlogand (cdr x) 15)))
(display " ")]
[else (write x)])))
(define convert-instruction**
(let ([convert-instruction convert-instruction])
(lambda (x ac)
(display "Convert ")
(write x)
(newline)
(let ([nc (convert-instruction x ac)])
(for-each write/x (diff nc ac))
(newline)
nc))))
(define compute-code-size
(lambda (ls)
(fold (lambda (x ac)
(case (car x)
[(byte) (fx+ ac 1)]
[(word reloc-word reloc-word+) (fx+ ac 4)]
[(relative) (fx+ ac 4)]
[(label) ac]
[else (error 'compute-code-size "unknown instr ~s" x)]))
0
ls)))
(define compute-reloc-size
(lambda (ls)
(fold (lambda (x ac)
(case (car x)
[(reloc-word) (fx+ ac 4)]
[(reloc-word+) (fx+ ac 8)]
[(relative) (fx+ ac 4)]
[(word byte label) ac]
[else (error 'compute-reloc-size "unknown instr ~s" x)]))
0
ls)))
(define set-label-loc!
(lambda (x loc)
(when (getprop x '*label-loc*)
(error 'compile "label ~s is already defined" x))
(putprop x '*label-loc* loc)))
(define label-loc
(lambda (x)
(or (getprop x '*label-loc*)
(error 'compile "undefined label ~s" x))))
(define unset-label-loc!
(lambda (x)
(remprop x '*label-loc*)))
(define whack-instructions
(lambda (x ls)
(define f
(lambda (ls idx reloc)
(cond
[(null? ls) reloc]
[else
(let ([a (car ls)])
(case (car a)
[(byte)
(set-code-byte! x idx (cdr a))
(f (cdr ls) (fx+ idx 1) reloc)]
[(reloc-word reloc-word+)
(let ([v (cdr a)])
(f (cdr ls) (fx+ idx 4) (cons (cons idx a) reloc)))]
[(relative)
(f (cdr ls) (fx+ idx 4) (cons (cons idx a) reloc))]
[(word)
(let ([v (cdr a)])
(set-code-word! x idx v)
(f (cdr ls) (fx+ idx 4) reloc))]
[(label)
(set-label-loc! (cdr a) (cons x idx))
(f (cdr ls) idx reloc)]
[else
(error 'whack-instructions "unknown instr ~s" a)]))])))
(f ls 0 '())))
(define wordsize 4)
(define whack-reloc
(lambda (code)
(define reloc-idx 0)
(lambda (r)
(let ([idx (car r)] [type (cadr r)] [v (cddr r)])
(case type
[(reloc-word)
(set-code-object! code v idx reloc-idx)
(set! reloc-idx (fxadd1 reloc-idx))]
[(reloc-word+)
(let ([obj (car v)] [disp (cdr v)])
(set-code-object+offset! code obj idx disp reloc-idx)
(set! reloc-idx (fx+ reloc-idx 2)))]
[(relative)
(let ([loc (label-loc v)])
(let ([obj (car loc)] [off (cdr loc)])
(set-code-object+offset/rel!
code obj idx (fx+ off 11) reloc-idx)))
(set! reloc-idx (fx+ reloc-idx 2))]
[else (error 'whack-reloc "invalid reloc type ~s" type)]))
)))
;;; (define list->code
;;; (lambda (ls)
;;; (let ([ls (convert-instructions ls)])
;;; (let ([n (compute-code-size ls)]
;;; [m (compute-reloc-size ls)])
;;; (let ([x (make-code n m 1)])
;;; (let ([reloc* (whack-instructions x ls)])
;;; (for-each (whack-reloc x) reloc*))
;;; (make-code-executable! x)
;;; x)))))
(define list*->code*
(lambda (ls*)
(let ([ls* (map convert-instructions ls*)])
(let ([n* (map compute-code-size ls*)]
[m* (map compute-reloc-size ls*)])
(let ([code* (map (lambda (n m) (make-code n m 1)) n* m*)])
(let ([reloc** (map whack-instructions code* ls*)])
(for-each
(lambda (code reloc*)
(for-each (whack-reloc code) reloc*))
code* reloc**)
(for-each make-code-executable! code*)
code*))))))
(define list->code
(lambda (ls)
(car (list*->code* (list ls)))))
($pcb-set! |#list*->code*| list*->code*)
)

1
src/build-date.tmp Normal file
View File

@ -0,0 +1 @@
2006-07-19

67
src/chez-compat.ss Normal file
View File

@ -0,0 +1,67 @@
(define-syntax $pcb-set!
(syntax-rules ()
[(_ name val)
(set-top-level-value! 'name val)]))
(define (immediate? x)
(or (fixnum? x)
(char? x)
(boolean? x)
(eof-object? x)
(eq? x (void))))
(define-syntax add1 syntax-error)
(define fxadd1
(lambda (x)
(unless (fixnum? x) (error 'fxadd1 "~s is not a fixnum" x))
(let ([v (+ x 1)])
(unless (fixnum? v) (error 'fxadd1 "overflow"))
v)))
(define-syntax sub1 syntax-error)
(define fxsub1
(lambda (x)
(unless (fixnum? x) (error 'fxsub1 "~s is not a fixnum" x))
(let ([v (- x 1)])
(unless (fixnum? v) (error 'fxsub1 "overflow"))
v)))
(define-syntax - syntax-error)
(define-syntax fx-
(let ()
(import scheme)
(syntax-rules ()
[(_ x y) (#%fx- x y)])))
(define-syntax * syntax-error)
(define-syntax fx*
(let ()
(import scheme)
(syntax-rules ()
[(_ x y) (#%fx* x y)])))
(define-syntax + syntax-error)
(define-syntax fx+
(let ()
(import scheme)
(syntax-rules ()
[(_ x y) (#%fx+ x y)])))
(define-syntax = syntax-error)
(define-syntax fx=
(let ()
(import scheme)
(syntax-rules ()
[(_ x y) (#%fx= x y)])))
(define-syntax integer? syntax-error)
(define char= char=?)

399
src/collect-5.2.c Normal file
View File

@ -0,0 +1,399 @@
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <sys/mman.h>
#include <assert.h>
#include "scheme.h"
typedef struct root_t{
int count;
char** start;
struct root_t* next;
} root_t;
void S_add_roots(pcb_t* pcb, int* f){
int n = *f;
if(n == 0) return;
root_t* t = malloc(sizeof(root_t));
if(t == NULL){
fprintf(stderr, "Error mallocing\n");
exit(-1);
}
t->count = n;
t->start = (char**)(f+1);
t->next = (root_t*) pcb->roots;
pcb->roots = (char*) t;
int i;
for(i=1; i<=n; i++){
assert(f[i] == 0);
}
}
void S_check_roots(pcb_t* pcb, int* f){
int n = *f;
int i;
for(i=1; i<=n; i++){
assert(f[i] != 0);
}
}
/* S_collect is called from scheme under the following conditions:
* 1. An attempt is made to allocate a small object and the ap is above
* the red line.
* 2. The current frame of the call is dead, so, upon return from S_collect,
* the caller returns to its caller.
* 3. The frame-pointer of the caller to S_collect is saved at
* pcb->stack_extent. No variables are live at that frame except for
* the return point (at *(pcb->stack_extent)).
* 4. S_collect must return a new ap (in pcb->allocation_pointer) that has
* at least 2 pages of memory free.
* 5. S_collect must also update pcb->allocaton_red_line to be 2 pages below
* the real end of heap.
* 6. S_collect should not move the stack.
*/
#define pagesize 4096
#define minimum_heap_size (pagesize * 640)
#define align_to_page(x) (((x)/pagesize)*pagesize)
static char* allocate_unprotected_space(int size);
static void deallocate_unprotected_space(char* p, int size);
static void deallocate_string_pages(char*);
static void copy_roots(pcb_t* pcb);
static char* move_object(char* x, pcb_t* pcb);
pcb_t* S_collect(int req, pcb_t* pcb){
#if 0
fprintf(stderr, "S_collect entry %d (pcb=0x%08x)\n", req, (int)pcb);
#endif
char* heap_base = pcb->heap_base;
#if 0
int heap_size = (int)pcb->heap_size;
fprintf(stderr, "heapsize=0x%08x (0x%08x .. 0x%08x)\n",
heap_size,
(int) heap_base,
(int) (heap_base + heap_size - 1));
#endif
int used_space = (int)(pcb->allocation_pointer - heap_base);
{
int bytes = (int) pcb->allocated_bytes + (used_space & 0xFFFFF);
pcb->allocated_megs += (bytes >> 20);
pcb->allocated_bytes = (char*) (bytes & 0xFFFFF);
#if 0
fprintf(stderr, "allocated %d megs and %d bytes so far\n",
(int) pcb->allocated_megs,
(int) pcb->allocated_bytes);
#endif
}
int required_space = align_to_page(used_space + 2*pagesize);
if(required_space < minimum_heap_size){
required_space = minimum_heap_size;
}
char* old_heap = pcb->heap_base;
int old_size = (int)pcb->heap_size;
char* old_string_pages = pcb->string_pages;
pcb->string_pages = 0;
char* new_heap = allocate_unprotected_space(required_space);
pcb->allocation_pointer = new_heap;
pcb->allocation_redline = new_heap + required_space - 2 * pagesize;
pcb->heap_base = new_heap;
pcb->heap_size = (char*) required_space;
copy_roots(pcb);
char** p = (char**) new_heap;
while(p != (char**) pcb->allocation_pointer){
*p = move_object(*p, pcb);
p++;
}
deallocate_unprotected_space(old_heap, old_size);
deallocate_string_pages(old_string_pages);
return pcb;
}
#define fixnump(x) ((((int)(x)) & fx_mask) == fx_tag)
#define closurep(x) ((((int)(x)) & closure_mask) == closure_tag)
#define immediatep(x) ((((int)(x)) & 7) == 7)
#define tagof(x) (((int) (x)) & 7)
#define ref(x,t) (*((char**)(((char*)(x))+((int)(t)))))
#define align(x) ((((x)+object_alignment-1)>>align_shift)<<align_shift)
typedef struct page_t{
char* base;
char* end;
struct page_t* next;
} page_t;
static page_t* make_page_t(){
page_t* p = malloc(sizeof(page_t));
if(p == NULL){
fprintf(stderr, "failed to allocate page");
exit(-1);
}
return p;
}
static void deallocate_string_pages(char* old_string_pages){
page_t* p;
p = (page_t*) old_string_pages;
while(p){
deallocate_unprotected_space(p->base, p->end - p->base);
p=p->next;
}
p = (page_t*) old_string_pages;
while(p){
page_t* n = p->next;
free(p);
p = n;
}
}
#if 0
static char* extend_pointer_ap(pcb_t* pcb, int size){
if(pcb->pointer_base){
page_t* p = make_page_t();
p->base = pcb->pointer_base;
p->end = pcb->pointer_ap;
p->next = (page_t*) pcb->pointer_pages;
pcb->pointer_pages = (char*) p;
}
char* ap = allocate_unprotected_space(size);
pcb->pointer_base = ap;
pcb->pointer_ap = ap;
pcb->pointer_eap = ap + size;
return ap;
}
#endif
static char* alloc_large_string(pcb_t* pcb, int size){
char* ap = allocate_unprotected_space(size);
page_t* p = make_page_t();
p->base = ap;
p->end = ap+size;
p->next = (page_t*) pcb->string_pages;
pcb->string_pages = (char*) p;
return ap;
}
static char* extend_string_ap(pcb_t* pcb, int size){
if(pcb->string_base){
page_t* p = make_page_t();
p->base = pcb->string_base;
p->end = pcb->string_ap;
p->next = (page_t*) pcb->string_pages;
pcb->string_pages = (char*) p;
}
char* ap = allocate_unprotected_space(size);
pcb->string_base = ap;
pcb->string_ap = ap;
pcb->string_eap = ap + size;
return ap;
}
static char* move_string(char* s, pcb_t* pcb){
int len = (int) ref(s, -string_tag);
int sz = align((len>>fx_shift)+disp_string_data+1);
if(sz < pagesize){
char* ap = pcb->string_ap;
char* nap = ap + sz;
if(nap > pcb->string_eap){
ap = extend_string_ap(pcb, pagesize);
pcb->string_eap = ap + pagesize;
nap = ap + sz;
}
pcb->string_ap = nap;
memcpy(ap, s-string_tag, sz);
ref(s,-string_tag) = (char*)-1;
ref(s,wordsize-string_tag) = ap+string_tag;
return ap + string_tag;
}
else {
char* ap = alloc_large_string(pcb, sz);
memcpy(ap, s-string_tag, sz);
ref(s,-string_tag) = (char*)-1;
ref(s,wordsize-string_tag) = ap+string_tag;
return ap + string_tag;
}
}
static char* move_pointers(char* x, pcb_t* pcb, int size, int tag){
int sz = align(size);
char* ap = pcb->allocation_pointer;
char* nap = ap + sz;
pcb->allocation_pointer = nap;
ref(nap, -wordsize) = 0;
memcpy(ap, x, size);
ref(x,0) = (char*)-1;
ref(x,wordsize) = ap + tag;
return ap + tag;
}
static char* move_object(char* x, pcb_t* pcb){
if(fixnump(x)){
return x;
}
else if(immediatep(x)){
return x;
}
else {
int tag = tagof(x);
char* fst = ref(x, -tag);
if(fst == (char*)-1){
return ref(x,wordsize-tag);
}
else if(tag == pair_tag){
return(move_pointers(x-tag, pcb, pair_size, tag));
}
else if(tag == closure_tag){
assert(ref(fst, -2*wordsize) == 0);
int size = (int) ref(fst, -wordsize);
assert(fixnump(size));
assert(size > 0);
return(move_pointers(x-tag, pcb, size, tag));
}
else if(tag == symbol_tag){
return(move_pointers(x-tag, pcb, symbol_size, tag));
}
else if(tag == vector_tag){
return(move_pointers(x-tag, pcb, disp_vector_data + (int)fst, tag));
}
else if(tag == string_tag){
return(move_string(x, pcb));
}
else {
fprintf(stderr, "here tag=%d\n", tag);
exit(-1);
}
}
}
static void copy_roots(pcb_t* pcb){
/* first, the constants */
root_t* r = (root_t*)pcb->roots;
while(r){
int n = r->count;
#if 0
fprintf(stderr, "copying root 0x%08x (%d objs) \n", (int)r, n);
#endif
char** f = r->start;
int i;
for(i=0; i<n; i++){
f[i] = move_object(f[i], pcb);
}
r = r->next;
}
/* next, the pcb-primitives */
char** fst = &pcb->scheme_objects;
char** end = &pcb->scheme_objects_end;
fst++;
while(fst < end){
*fst = move_object(*fst, pcb);
fst++;
}
/* next, the stack */
#define FRAMESIZE_OFFSET -9
char* fp = pcb->stack_extent;
char* stack_base = pcb->scheme_stack;
while(fp != stack_base){
assert(fp < stack_base);
#if 0
fprintf(stderr, "copying frame at 0x%08x of 0x%08x\n",
(int)fp, (int)stack_base);
#endif
char* rp = ref(fp, 0);
#if 0
fprintf(stderr, "return-point = 0x%08x\n", (int)rp);
#endif
int framesize = (int) ref(rp, FRAMESIZE_OFFSET); /* UGLY */
assert(fixnump(framesize));
assert(framesize >= 0);
if(framesize > 0){
int bytes_in_mask = ((framesize>>fx_shift)+7)>>3;
char* mask = rp + FRAMESIZE_OFFSET - bytes_in_mask;
fp = fp + framesize;
char** fpp = (char**) fp;
int i;
for(i=0; i<bytes_in_mask; i++){
unsigned char m = mask[i];
if(m){
if (m & 0x01) {
fpp[0] = move_object(fpp[0], pcb);
}
if (m & 0x02) {
fpp[-1] = move_object(fpp[-1], pcb);
}
if (m & 0x04) {
fpp[-2] = move_object(fpp[-2], pcb);
}
if (m & 0x08) {
fpp[-3] = move_object(fpp[-3], pcb);
}
if (m & 0x10) {
fpp[-4] = move_object(fpp[-4], pcb);
}
if (m & 0x20) {
fpp[-5] = move_object(fpp[-5], pcb);
}
if (m & 0x40) {
fpp[-6] = move_object(fpp[-6], pcb);
}
if (m & 0x80) {
fpp[-7] = move_object(fpp[-7], pcb);
}
}
fpp -= 8;
}
}
else if(framesize == 0){
framesize = (int)ref(fp, wordsize);
assert(fixnump(framesize));
assert(framesize > 0);
#if 0
/* move cp */
{
char* cp = ref(fp, 2*wordsize);
assert(closurep(cp));
ref(fp, 2*wordsize) = move_object(cp, pcb);
}
#endif
fp += framesize;
int i;
for(i=wordsize; i<(framesize); i+=wordsize){
ref(fp, -i) = move_object(ref(fp,-i), pcb);
}
}
else {
fprintf(stderr, "Error: framesize is %d\n", framesize);
exit(-10);
}
}
}
static char* allocate_unprotected_space(int size){
int aligned_size = ((size + pagesize - 1) / pagesize) * pagesize;
char* p = mmap(0, aligned_size,
PROT_READ | PROT_WRITE,
MAP_ANONYMOUS | MAP_PRIVATE,
0, 0);
if(p == MAP_FAILED){
perror("allocate_unprotected_space failed to mmap");
exit(-10);
}
return p;
}
static void deallocate_unprotected_space(char* p, int size){
int status;
int aligned_size = ((size + pagesize - 1) / pagesize) * pagesize;
status = munmap(p, aligned_size);
if(status != 0){
perror("deallocate_unprotected_space failed to unmap");
exit(-10);
}
}

6
src/collect-5.2.h Normal file
View File

@ -0,0 +1,6 @@
#ifndef COLLECT_H
#define COLLECT_H
#include "scheme.h"
void S_add_roots(pcb_t*, int*);
void S_check_roots(pcb_t*, int*);
#endif

572
src/collect-5.3.c Normal file
View File

@ -0,0 +1,572 @@
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <sys/mman.h>
#include <assert.h>
#include "scheme.h"
typedef struct root_t{
int count;
char** start;
struct root_t* next;
} root_t;
void S_add_roots(pcb_t* pcb, int* f){
int n = *f;
if(n == 0) return;
root_t* t = malloc(sizeof(root_t));
if(t == NULL){
fprintf(stderr, "Error mallocing\n");
exit(-1);
}
t->count = n;
t->start = (char**)(f+1);
t->next = (root_t*) pcb->roots;
pcb->roots = (char*) t;
int i;
for(i=1; i<=n; i++){
assert(f[i] == 0);
}
}
void S_check_roots(pcb_t* pcb, int* f){
int n = *f;
int i;
for(i=1; i<=n; i++){
assert(f[i] != 0);
}
}
/* S_collect is called from scheme under the following conditions:
* 1. An attempt is made to allocate a small object and the ap is above
* the red line.
* 2. The current frame of the call is dead, so, upon return from S_collect,
* the caller returns to its caller.
* 3. The frame-pointer of the caller to S_collect is saved at
* pcb->stack_extent. No variables are live at that frame except for
* the return point (at *(pcb->stack_extent)).
* 4. S_collect must return a new ap (in pcb->allocation_pointer) that has
* at least 2 pages of memory free.
* 5. S_collect must also update pcb->allocaton_red_line to be 2 pages below
* the real end of heap.
* 6. S_collect should not move the stack.
*/
#define pagesize 4096
#define minimum_heap_size (pagesize * 1024 * 4)
#define maximum_heap_size (pagesize * 1024 * 8)
#define minimum_stack_size (pagesize * 128)
#define align_to_page(x) (((x)/pagesize)*pagesize)
static char* allocate_unprotected_space(int size);
static void deallocate_unprotected_space(char* p, int size);
static void deallocate_string_pages(char*);
static void copy_roots(pcb_t* pcb);
static char* move_object(char* x, pcb_t* pcb);
pcb_t* S_collect(int req, pcb_t* pcb){
#if 0
fprintf(stderr, "S_collect entry %d (pcb=0x%08x)\n", req, (int)pcb);
#endif
char* heap_base = pcb->heap_base;
#if 0
int heap_size = (int)pcb->heap_size;
fprintf(stderr, "heapsize=0x%08x (0x%08x .. 0x%08x)\n",
heap_size,
(int) heap_base,
(int) (heap_base + heap_size - 1));
#endif
int used_space = (int)(pcb->allocation_pointer - heap_base);
{
int bytes = (int) pcb->allocated_bytes + (used_space & 0xFFFFF);
pcb->allocated_megs += (bytes >> 20);
pcb->allocated_bytes = (char*) (bytes & 0xFFFFF);
#if 0
fprintf(stderr, "allocated %d megs and %d bytes so far\n",
(int) pcb->allocated_megs,
(int) pcb->allocated_bytes);
#endif
}
int required_space = align_to_page(used_space + 2 * req + 2 * pagesize);
if(required_space < minimum_heap_size){
required_space = minimum_heap_size;
}
if(required_space > maximum_heap_size){
fprintf(stderr, "Maximum heapsize exceeded\n");
exit(-1);
}
char* old_heap = pcb->heap_base;
int old_size = (int)pcb->heap_size;
char* old_string_pages = pcb->string_pages;
pcb->string_pages = 0;
char* new_heap = allocate_unprotected_space(maximum_heap_size);
pcb->allocation_pointer = new_heap;
pcb->allocation_redline = new_heap + maximum_heap_size - 2 * pagesize;
pcb->heap_base = new_heap;
pcb->heap_size = (char*) maximum_heap_size;
copy_roots(pcb);
char** p = (char**) new_heap;
while(p != (char**) pcb->allocation_pointer){
*p = move_object(*p, pcb);
p++;
}
deallocate_unprotected_space(old_heap, old_size);
deallocate_string_pages(old_string_pages);
{
int free_space =
(int)pcb->allocation_redline - (int)pcb->allocation_pointer;
int diff = align_to_page(free_space - minimum_heap_size);
if(diff > 0){
deallocate_unprotected_space(
pcb->heap_base + (int)pcb->heap_size - diff,
diff);
pcb->allocation_redline -= diff;
pcb->heap_size -= diff;
}
}
#if 0
fprintf(stderr, "ap=0x%08x limit=0x%08x\n",
(int)pcb->allocation_pointer,
(int)pcb->heap_base+(int)pcb->heap_size-wordsize);
#endif
return pcb;
}
#define fixnump(x) ((((int)(x)) & fx_mask) == fx_tag)
#define closurep(x) ((((int)(x)) & closure_mask) == closure_tag)
#define immediatep(x) ((((int)(x)) & 7) == 7)
#define tagof(x) (((int) (x)) & 7)
#define ref(x,t) (*((char**)(((char*)(x))+((int)(t)))))
#define align(x) ((((x)+object_alignment-1)>>align_shift)<<align_shift)
typedef struct page_t{
char* base;
char* end;
struct page_t* next;
} page_t;
static page_t* make_page_t(){
page_t* p = malloc(sizeof(page_t));
if(p == NULL){
fprintf(stderr, "failed to allocate page");
exit(-1);
}
return p;
}
static void deallocate_string_pages(char* old_string_pages){
page_t* p;
p = (page_t*) old_string_pages;
while(p){
deallocate_unprotected_space(p->base, p->end - p->base);
p=p->next;
}
p = (page_t*) old_string_pages;
while(p){
page_t* n = p->next;
free(p);
p = n;
}
}
#if 0
static char* extend_pointer_ap(pcb_t* pcb, int size){
if(pcb->pointer_base){
page_t* p = make_page_t();
p->base = pcb->pointer_base;
p->end = pcb->pointer_ap;
p->next = (page_t*) pcb->pointer_pages;
pcb->pointer_pages = (char*) p;
}
char* ap = allocate_unprotected_space(size);
pcb->pointer_base = ap;
pcb->pointer_ap = ap;
pcb->pointer_eap = ap + size;
return ap;
}
#endif
static char* alloc_large_string(pcb_t* pcb, int size){
char* ap = allocate_unprotected_space(size);
page_t* p = make_page_t();
p->base = ap;
p->end = ap+size;
p->next = (page_t*) pcb->string_pages;
pcb->string_pages = (char*) p;
return ap;
}
static char* extend_string_ap(pcb_t* pcb, int size){
if(pcb->string_base){
page_t* p = make_page_t();
p->base = pcb->string_base;
p->end = pcb->string_ap;
p->next = (page_t*) pcb->string_pages;
pcb->string_pages = (char*) p;
}
char* ap = allocate_unprotected_space(size);
pcb->string_base = ap;
pcb->string_ap = ap;
pcb->string_eap = ap + size;
return ap;
}
static char* move_string(char* s, pcb_t* pcb){
int len = (int) ref(s, -string_tag);
int sz = align((len>>fx_shift)+disp_string_data+1);
if(sz < pagesize){
char* ap = pcb->string_ap;
char* nap = ap + sz;
if(nap > pcb->string_eap){
ap = extend_string_ap(pcb, pagesize);
pcb->string_eap = ap + pagesize;
nap = ap + sz;
}
pcb->string_ap = nap;
memcpy(ap, s-string_tag, sz);
ref(s,-string_tag) = (char*)-1;
ref(s,wordsize-string_tag) = ap+string_tag;
return ap + string_tag;
}
else {
char* ap = alloc_large_string(pcb, sz);
memcpy(ap, s-string_tag, sz);
ref(s,-string_tag) = (char*)-1;
ref(s,wordsize-string_tag) = ap+string_tag;
return ap + string_tag;
}
}
static void munch_stack(char* fp, pcb_t* pcb, char* frame_base){
#define FRAMESIZE_OFFSET -9
while(fp != frame_base){
assert(fp < frame_base);
#if 0
fprintf(stderr, "copying frame at 0x%08x of 0x%08x\n",
(int)fp, (int)stack_base);
#endif
char* rp = ref(fp, 0);
#if 0
fprintf(stderr, "return-point = 0x%08x\n", (int)rp);
#endif
int framesize = (int) ref(rp, FRAMESIZE_OFFSET); /* UGLY */
assert(fixnump(framesize));
assert(framesize >= 0);
if(framesize > 0){
int bytes_in_mask = ((framesize>>fx_shift)+7)>>3;
char* mask = rp + FRAMESIZE_OFFSET - bytes_in_mask;
fp = fp + framesize;
char** fpp = (char**) fp;
int i;
for(i=0; i<bytes_in_mask; i++){
unsigned char m = mask[i];
if(m){
if (m & 0x01) {
fpp[0] = move_object(fpp[0], pcb);
}
if (m & 0x02) {
fpp[-1] = move_object(fpp[-1], pcb);
}
if (m & 0x04) {
fpp[-2] = move_object(fpp[-2], pcb);
}
if (m & 0x08) {
fpp[-3] = move_object(fpp[-3], pcb);
}
if (m & 0x10) {
fpp[-4] = move_object(fpp[-4], pcb);
}
if (m & 0x20) {
fpp[-5] = move_object(fpp[-5], pcb);
}
if (m & 0x40) {
fpp[-6] = move_object(fpp[-6], pcb);
}
if (m & 0x80) {
fpp[-7] = move_object(fpp[-7], pcb);
}
}
fpp -= 8;
}
}
else if(framesize == 0){
framesize = (int)ref(fp, wordsize);
assert(fixnump(framesize));
assert(framesize > 0);
#if 0
/* move cp */
{
char* cp = ref(fp, 2*wordsize);
assert(closurep(cp));
ref(fp, 2*wordsize) = move_object(cp, pcb);
}
#endif
fp += framesize;
int i;
for(i=wordsize; i<(framesize); i+=wordsize){
ref(fp, -i) = move_object(ref(fp,-i), pcb);
}
}
else {
fprintf(stderr, "Error: framesize is %d\n", framesize);
exit(-10);
}
}
}
static char* move_stack(char* s, pcb_t* pcb, int sz){
char* ns;
int asz = align(sz);
if(asz < pagesize){
char* ap = pcb->string_ap;
char* nap = ap + asz;
if(nap > pcb->string_eap){
ap = extend_string_ap(pcb, pagesize);
pcb->string_eap = ap + pagesize;
nap = ap + asz;
}
pcb->string_ap = nap;
ns = ap;
}
else {
ns = alloc_large_string(pcb, asz);
}
memcpy(ns, s, sz);
munch_stack(ns, pcb, ns+sz);
return ns;
}
static char* move_pointers(char* x, pcb_t* pcb, int size, int tag){
int sz = align(size);
char* ap = pcb->allocation_pointer;
char* nap = ap + sz;
pcb->allocation_pointer = nap;
ref(nap, -wordsize) = 0;
memcpy(ap, x, size);
ref(x,0) = (char*)-1;
ref(x,wordsize) = ap + tag;
return ap + tag;
}
static char* move_continuation(char* x, pcb_t* pcb){
int sz = (int) ref(x, disp_continuation_size);
char* top = ref(x, disp_continuation_top);
char* r = move_pointers(x, pcb, continuation_size, vector_tag);
ref(r, disp_continuation_top - vector_tag) = move_stack(top, pcb, sz);
return r;
}
static char* move_object(char* x, pcb_t* pcb){
if(fixnump(x)){
return x;
}
else if(immediatep(x)){
return x;
}
else {
int tag = tagof(x);
char* fst = ref(x, -tag);
if(fst == (char*)-1){
return ref(x,wordsize-tag);
}
else if(tag == pair_tag){
return(move_pointers(x-tag, pcb, pair_size, tag));
}
else if(tag == closure_tag){
assert(ref(fst, -2*wordsize) == 0);
int size = (int) ref(fst, -wordsize);
assert(fixnump(size));
assert(size > 0);
return (move_pointers(x-tag, pcb, size, tag));
}
else if(tag == symbol_tag){
return (move_pointers(x-tag, pcb, symbol_size, tag));
}
else if(tag == vector_tag){
if(fixnump(fst)){
return (move_pointers(x-tag, pcb, disp_vector_data + (int)fst, tag));
}
else if(fst == (char*)continuation_tag){
return (move_continuation(x-tag, pcb));
}
else {
fprintf(stderr, "nonvec 0x%08x 0x%08x\n", (int)x, (int)fst);
exit(-1);
}
}
else if(tag == string_tag){
return (move_string(x, pcb));
}
else {
fprintf(stderr, "here tag=%d\n", tag);
exit(-1);
}
}
}
static void copy_roots(pcb_t* pcb){
/* first, the constants */
root_t* r = (root_t*)pcb->roots;
while(r){
int n = r->count;
char** f = r->start;
int i;
for(i=0; i<n; i++){
f[i] = move_object(f[i], pcb);
}
r = r->next;
}
/* next, the pcb-primitives */
char** fst = &pcb->scheme_objects;
char** end = &pcb->scheme_objects_end;
fst++;
while(fst < end){
*fst = move_object(*fst, pcb);
fst++;
}
/* next, the stack */
char* fp = pcb->frame_pointer;
char* frame_base = pcb->frame_base;
munch_stack(fp, pcb, frame_base);
}
static char* allocate_unprotected_space(int size){
int aligned_size = ((size + pagesize - 1) / pagesize) * pagesize;
char* p = mmap(0, aligned_size,
PROT_READ | PROT_WRITE,
MAP_ANONYMOUS | MAP_PRIVATE,
0, 0);
if(p == MAP_FAILED){
perror("allocate_unprotected_space failed to mmap");
exit(-10);
}
return p;
}
static void deallocate_unprotected_space(char* p, int size){
int status;
int aligned_size = ((size + pagesize - 1) / pagesize) * pagesize;
status = munmap(p, aligned_size);
if(status != 0){
perror("deallocate_unprotected_space failed to unmap");
exit(-10);
}
}
void S_stack_overflow(pcb_t* pcb){
// fprintf(stderr, "stack overflow detected\n");
char* stack_top = pcb->stack_top;
int stack_size = (int) pcb->stack_size;
char* fp = pcb->frame_pointer;
char* frame_base = pcb->frame_base;
assert(fp != frame_base);
char* rp = ref(fp, 0);
int framesize = (int) ref(rp, FRAMESIZE_OFFSET); /* UGLY */
assert(fixnump(framesize));
assert(framesize >= 0);
if(framesize == 0){
framesize = (int)ref(fp, wordsize);
assert(fixnump(framesize));
}
// fprintf(stderr, "framesize = %d bytes\n", framesize);
{ /* capture continuation */
char* next_frame_top = fp + framesize;
if(next_frame_top == frame_base){
fprintf(stderr, "continuation already captured\n");
} else {
//fprintf(stderr, "capturing continuation ... ");
char* cont = pcb->allocation_pointer;
pcb->allocation_pointer += continuation_size;
ref(cont, 0) = (char*) continuation_tag;
ref(cont, disp_continuation_top) = next_frame_top;
ref(cont, disp_continuation_next) = pcb->next_continuation;
ref(cont, disp_continuation_size) =
frame_base - (int)next_frame_top;
pcb->next_continuation = cont + vector_tag;
//fprintf(stderr, "done (sz=0x%08x)\n",
// (int) ref(cont, disp_continuation_size));
}
}
int req_stack_size = align_to_page(framesize * 4 + 2 * pagesize);
if(req_stack_size < minimum_stack_size){
req_stack_size = minimum_stack_size;
}
char* new_stack = allocate_unprotected_space(req_stack_size);
char* new_frame_redline = new_stack + 2 * pagesize;
char* new_frame_base = new_stack + req_stack_size - wordsize;
ref(new_frame_base, 0) = ref(frame_base, 0); /* underflow handler */
memcpy(new_frame_base - framesize, fp, framesize);
pcb->stack_top = new_stack;
pcb->stack_size = (char*)req_stack_size;
pcb->frame_base = new_frame_base;
pcb->frame_pointer = new_frame_base - framesize;
pcb->frame_redline = new_frame_redline;
/*
fprintf(stderr, "stack=0x%08x .. 0x%08x (redline=0x%08x) fp=0x%08x\n",
(int) pcb->frame_base,
(int) pcb->stack_top,
(int) pcb->frame_redline,
(int) pcb->frame_pointer);
fprintf(stderr, "returning ... \n");
*/
return;
}
/*
On overflow:
+--------------+
| unused |
| area |
| |
+--------------+
| rp | <-- frame pointer on overflow
+--------------+
| frame |
| when |
| overflow |
| occured |
+--------------+
| rp_next | <-- capture next conitnuation here
+--------------+ (unless we're at base already)
| ... |
| ... |
| ... |
+--------------+
| underflow |
+--------------+
New stack:
+--------------+
| unused |
| area |
| |
| |
| |
| |
| |
| |
| |
| |
+--------------+
| rp | <-- frame pointer on return
+--------------+
| frame |
| when |
| overflow |
| occured |
+--------------+
| underflow |
+--------------+
*/

580
src/collect-5.4.c Normal file
View File

@ -0,0 +1,580 @@
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <sys/mman.h>
#include <assert.h>
#include "scheme.h"
typedef struct root_t{
int count;
char** start;
struct root_t* next;
} root_t;
void S_add_roots(pcb_t* pcb, int* f){
int n = *f;
if(n == 0) return;
root_t* t = malloc(sizeof(root_t));
if(t == NULL){
fprintf(stderr, "Error mallocing\n");
exit(-1);
}
t->count = n;
t->start = (char**)(f+1);
t->next = (root_t*) pcb->roots;
pcb->roots = (char*) t;
int i;
for(i=1; i<=n; i++){
assert(f[i] == 0);
}
}
void S_check_roots(pcb_t* pcb, int* f){
int n = *f;
int i;
for(i=1; i<=n; i++){
assert(f[i] != 0);
}
}
/* S_collect is called from scheme under the following conditions:
* 1. An attempt is made to allocate a small object and the ap is above
* the red line.
* 2. The current frame of the call is dead, so, upon return from S_collect,
* the caller returns to its caller.
* 3. The frame-pointer of the caller to S_collect is saved at
* pcb->stack_extent. No variables are live at that frame except for
* the return point (at *(pcb->stack_extent)).
* 4. S_collect must return a new ap (in pcb->allocation_pointer) that has
* at least 2 pages of memory free.
* 5. S_collect must also update pcb->allocaton_red_line to be 2 pages below
* the real end of heap.
* 6. S_collect should not move the stack.
*/
#define pagesize 4096
#define minimum_heap_size (pagesize * 1024 * 4)
#define maximum_heap_size (pagesize * 1024 * 8)
#define minimum_stack_size (pagesize * 128)
#define align_to_page(x) (((x)/pagesize)*pagesize)
static char* allocate_unprotected_space(int size);
static void deallocate_unprotected_space(char* p, int size);
static void deallocate_string_pages(char*);
static void copy_roots(pcb_t* pcb);
static char* move_object(char* x, pcb_t* pcb);
pcb_t* S_collect(int req, pcb_t* pcb){
#if 0
fprintf(stderr, "S_collect entry %d (pcb=0x%08x)\n", req, (int)pcb);
#endif
char* heap_base = pcb->heap_base;
#if 0
int heap_size = (int)pcb->heap_size;
fprintf(stderr, "heapsize=0x%08x (0x%08x .. 0x%08x)\n",
heap_size,
(int) heap_base,
(int) (heap_base + heap_size - 1));
#endif
int used_space = (int)(pcb->allocation_pointer - heap_base);
{
int bytes = (int) pcb->allocated_bytes + (used_space & 0xFFFFF);
pcb->allocated_megs += (bytes >> 20);
pcb->allocated_bytes = (char*) (bytes & 0xFFFFF);
#if 0
fprintf(stderr, "allocated %d megs and %d bytes so far\n",
(int) pcb->allocated_megs,
(int) pcb->allocated_bytes);
#endif
}
int required_space = align_to_page(used_space + 2 * req + 2 * pagesize);
if(required_space < minimum_heap_size){
required_space = minimum_heap_size;
}
if(required_space > maximum_heap_size){
fprintf(stderr, "Maximum heapsize exceeded\n");
exit(-1);
}
char* old_heap = pcb->heap_base;
int old_size = (int)pcb->heap_size;
char* old_string_pages = pcb->string_pages;
pcb->string_pages = 0;
char* new_heap = allocate_unprotected_space(maximum_heap_size);
pcb->allocation_pointer = new_heap;
pcb->allocation_redline = new_heap + maximum_heap_size - 2 * pagesize;
pcb->heap_base = new_heap;
pcb->heap_size = (char*) maximum_heap_size;
copy_roots(pcb);
char** p = (char**) new_heap;
while(p != (char**) pcb->allocation_pointer){
*p = move_object(*p, pcb);
p++;
}
deallocate_unprotected_space(old_heap, old_size);
deallocate_string_pages(old_string_pages);
{
int free_space =
(int)pcb->allocation_redline - (int)pcb->allocation_pointer;
int diff = align_to_page(free_space - minimum_heap_size);
if(diff > 0){
deallocate_unprotected_space(
pcb->heap_base + (int)pcb->heap_size - diff,
diff);
pcb->allocation_redline -= diff;
pcb->heap_size -= diff;
}
}
#if 0
fprintf(stderr, "ap=0x%08x limit=0x%08x\n",
(int)pcb->allocation_pointer,
(int)pcb->heap_base+(int)pcb->heap_size-wordsize);
#endif
return pcb;
}
#define fixnump(x) ((((int)(x)) & fx_mask) == fx_tag)
#define closurep(x) ((((int)(x)) & closure_mask) == closure_tag)
#define immediatep(x) ((((int)(x)) & 7) == 7)
#define tagof(x) (((int) (x)) & 7)
#define ref(x,t) (*((char**)(((char*)(x))+((int)(t)))))
#define align(x) ((((x)+object_alignment-1)>>align_shift)<<align_shift)
typedef struct page_t{
char* base;
char* end;
struct page_t* next;
} page_t;
static page_t* make_page_t(){
page_t* p = malloc(sizeof(page_t));
if(p == NULL){
fprintf(stderr, "failed to allocate page");
exit(-1);
}
return p;
}
static void deallocate_string_pages(char* old_string_pages){
page_t* p;
p = (page_t*) old_string_pages;
while(p){
deallocate_unprotected_space(p->base, p->end - p->base);
p=p->next;
}
p = (page_t*) old_string_pages;
while(p){
page_t* n = p->next;
free(p);
p = n;
}
}
#if 0
static char* extend_pointer_ap(pcb_t* pcb, int size){
if(pcb->pointer_base){
page_t* p = make_page_t();
p->base = pcb->pointer_base;
p->end = pcb->pointer_ap;
p->next = (page_t*) pcb->pointer_pages;
pcb->pointer_pages = (char*) p;
}
char* ap = allocate_unprotected_space(size);
pcb->pointer_base = ap;
pcb->pointer_ap = ap;
pcb->pointer_eap = ap + size;
return ap;
}
#endif
static char* alloc_large_string(pcb_t* pcb, int size){
char* ap = allocate_unprotected_space(size);
page_t* p = make_page_t();
p->base = ap;
p->end = ap+size;
p->next = (page_t*) pcb->string_pages;
pcb->string_pages = (char*) p;
return ap;
}
static char* extend_string_ap(pcb_t* pcb, int size){
if(pcb->string_base){
page_t* p = make_page_t();
p->base = pcb->string_base;
p->end = pcb->string_ap;
p->next = (page_t*) pcb->string_pages;
pcb->string_pages = (char*) p;
}
char* ap = allocate_unprotected_space(size);
pcb->string_base = ap;
pcb->string_ap = ap;
pcb->string_eap = ap + size;
return ap;
}
static char* move_string(char* s, pcb_t* pcb){
int len = (int) ref(s, -string_tag);
int sz = align((len>>fx_shift)+disp_string_data+1);
if(sz < pagesize){
char* ap = pcb->string_ap;
char* nap = ap + sz;
if(nap > pcb->string_eap){
ap = extend_string_ap(pcb, pagesize);
pcb->string_eap = ap + pagesize;
nap = ap + sz;
}
pcb->string_ap = nap;
memcpy(ap, s-string_tag, sz);
ref(s,-string_tag) = (char*)-1;
ref(s,wordsize-string_tag) = ap+string_tag;
return ap + string_tag;
}
else {
char* ap = alloc_large_string(pcb, sz);
memcpy(ap, s-string_tag, sz);
ref(s,-string_tag) = (char*)-1;
ref(s,wordsize-string_tag) = ap+string_tag;
return ap + string_tag;
}
}
static void munch_stack(char* fp, pcb_t* pcb, char* frame_base){
while(fp != frame_base){
assert(fp < frame_base);
#if 0
fprintf(stderr, "copying frame at 0x%08x of 0x%08x\n",
(int)fp, (int)stack_base);
#endif
char* rp = ref(fp, 0);
#if 0
fprintf(stderr, "return-point = 0x%08x\n", (int)rp);
#endif
int framesize = (int) ref(rp, disp_frame_size); /* UGLY */
assert(fixnump(framesize));
assert(framesize >= 0);
if(framesize > 0){
int bytes_in_mask = ((framesize>>fx_shift)+7)>>3;
char* mask = rp + disp_frame_size - bytes_in_mask;
fp = fp + framesize;
char** fpp = (char**) fp;
int i;
for(i=0; i<bytes_in_mask; i++){
unsigned char m = mask[i];
if(m){
if (m & 0x01) {
fpp[0] = move_object(fpp[0], pcb);
}
if (m & 0x02) {
fpp[-1] = move_object(fpp[-1], pcb);
}
if (m & 0x04) {
fpp[-2] = move_object(fpp[-2], pcb);
}
if (m & 0x08) {
fpp[-3] = move_object(fpp[-3], pcb);
}
if (m & 0x10) {
fpp[-4] = move_object(fpp[-4], pcb);
}
if (m & 0x20) {
fpp[-5] = move_object(fpp[-5], pcb);
}
if (m & 0x40) {
fpp[-6] = move_object(fpp[-6], pcb);
}
if (m & 0x80) {
fpp[-7] = move_object(fpp[-7], pcb);
}
}
fpp -= 8;
}
}
else if(framesize == 0){
framesize = (int)ref(fp, wordsize);
assert(fixnump(framesize));
assert(framesize > 0);
#if 0
/* move cp */
{
char* cp = ref(fp, 2*wordsize);
assert(closurep(cp));
ref(fp, 2*wordsize) = move_object(cp, pcb);
}
#endif
fp += framesize;
int i;
for(i=wordsize; i<(framesize); i+=wordsize){
ref(fp, -i) = move_object(ref(fp,-i), pcb);
}
}
else {
fprintf(stderr, "Error: framesize is %d\n", framesize);
exit(-10);
}
}
}
static char* move_stack(char* s, pcb_t* pcb, int sz){
char* ns;
int asz = align(sz);
if(asz < pagesize){
char* ap = pcb->string_ap;
char* nap = ap + asz;
if(nap > pcb->string_eap){
ap = extend_string_ap(pcb, pagesize);
pcb->string_eap = ap + pagesize;
nap = ap + asz;
}
pcb->string_ap = nap;
ns = ap;
}
else {
ns = alloc_large_string(pcb, asz);
}
memcpy(ns, s, sz);
munch_stack(ns, pcb, ns+sz);
return ns;
}
static char* move_pointers(char* x, pcb_t* pcb, int size, int tag){
int sz = align(size);
char* ap = pcb->allocation_pointer;
char* nap = ap + sz;
pcb->allocation_pointer = nap;
ref(nap, -wordsize) = 0;
memcpy(ap, x, size);
ref(x,0) = (char*)-1;
ref(x,wordsize) = ap + tag;
return ap + tag;
}
static char* move_continuation(char* x, pcb_t* pcb){
int sz = (int) ref(x, disp_continuation_size);
char* top = ref(x, disp_continuation_top);
char* r = move_pointers(x, pcb, continuation_size, vector_tag);
ref(r, disp_continuation_top - vector_tag) = move_stack(top, pcb, sz);
return r;
}
static char* move_object(char* x, pcb_t* pcb){
if(fixnump(x)){
return x;
}
else if(immediatep(x)){
return x;
}
else {
int tag = tagof(x);
char* fst = ref(x, -tag);
if(fst == (char*)-1){
return ref(x,wordsize-tag);
}
else if(tag == pair_tag){
return(move_pointers(x-tag, pcb, pair_size, tag));
}
else if(tag == closure_tag){
assert(ref(fst, -2*wordsize) == 0);
int size = (int) ref(fst, -wordsize);
assert(fixnump(size));
assert(size > 0);
return (move_pointers(x-tag, pcb, size, tag));
}
else if(tag == symbol_tag){
return (move_pointers(x-tag, pcb, symbol_size, tag));
}
else if(tag == vector_tag){
if(fixnump(fst)){
return (move_pointers(x-tag, pcb, disp_vector_data + (int)fst, tag));
}
else if(fst == (char*)continuation_tag){
return (move_continuation(x-tag, pcb));
}
else {
fprintf(stderr, "nonvec 0x%08x 0x%08x\n", (int)x, (int)fst);
exit(-1);
}
}
else if(tag == string_tag){
return (move_string(x, pcb));
}
else {
fprintf(stderr, "here tag=%d\n", tag);
exit(-1);
}
}
}
static void copy_roots(pcb_t* pcb){
/* first, the constants */
root_t* r = (root_t*)pcb->roots;
while(r){
int n = r->count;
char** f = r->start;
int i;
for(i=0; i<n; i++){
f[i] = move_object(f[i], pcb);
}
r = r->next;
}
/* next, the pcb-primitives */
char** fst = &pcb->scheme_objects;
char** end = &pcb->scheme_objects_end;
fst++;
while(fst < end){
*fst = move_object(*fst, pcb);
fst++;
}
/* next, the stack */
char* fp = pcb->frame_pointer;
char* frame_base = pcb->frame_base;
munch_stack(fp, pcb, frame_base);
}
static char* allocate_unprotected_space(int size){
int aligned_size = ((size + pagesize - 1) / pagesize) * pagesize;
char* p = mmap(0, aligned_size,
PROT_READ | PROT_WRITE,
MAP_ANONYMOUS | MAP_PRIVATE,
0, 0);
if(p == MAP_FAILED){
perror("allocate_unprotected_space failed to mmap");
exit(-10);
}
return p;
}
static void deallocate_unprotected_space(char* p, int size){
int status;
int aligned_size = ((size + pagesize - 1) / pagesize) * pagesize;
status = munmap(p, aligned_size);
if(status != 0){
perror("deallocate_unprotected_space failed to unmap");
exit(-10);
}
}
void S_stack_overflow(pcb_t* pcb){
// fprintf(stderr, "stack overflow detected\n");
char* stack_top = pcb->stack_top;
int stack_size = (int) pcb->stack_size;
char* fp = pcb->frame_pointer;
char* frame_base = pcb->frame_base;
assert(fp != frame_base);
char* rp = ref(fp, 0);
int framesize = (int) ref(rp, disp_frame_size); /* UGLY */
assert(fixnump(framesize));
assert(framesize >= 0);
if(framesize == 0){
framesize = (int)ref(fp, wordsize);
assert(fixnump(framesize));
}
// fprintf(stderr, "framesize = %d bytes\n", framesize);
{ /* capture continuation */
char* next_frame_top = fp + framesize;
if(next_frame_top == frame_base){
fprintf(stderr, "continuation already captured\n");
} else {
//fprintf(stderr, "capturing continuation ... ");
char* cont = pcb->allocation_pointer;
pcb->allocation_pointer += continuation_size;
ref(cont, 0) = (char*) continuation_tag;
ref(cont, disp_continuation_top) = next_frame_top;
ref(cont, disp_continuation_next) = pcb->next_continuation;
ref(cont, disp_continuation_size) =
frame_base - (int)next_frame_top;
pcb->next_continuation = cont + vector_tag;
//fprintf(stderr, "done (sz=0x%08x)\n",
// (int) ref(cont, disp_continuation_size));
}
}
int req_stack_size = align_to_page(framesize * 4 + 2 * pagesize);
if(req_stack_size < minimum_stack_size){
req_stack_size = minimum_stack_size;
}
char* new_stack = allocate_unprotected_space(req_stack_size);
char* new_frame_redline = new_stack + 2 * pagesize;
char* new_frame_base = new_stack + req_stack_size - wordsize;
ref(new_frame_base, 0) = ref(frame_base, 0); /* underflow handler */
memcpy(new_frame_base - framesize, fp, framesize);
pcb->stack_top = new_stack;
pcb->stack_size = (char*)req_stack_size;
pcb->frame_base = new_frame_base;
pcb->frame_pointer = new_frame_base - framesize;
pcb->frame_redline = new_frame_redline;
/*
fprintf(stderr, "stack=0x%08x .. 0x%08x (redline=0x%08x) fp=0x%08x\n",
(int) pcb->frame_base,
(int) pcb->stack_top,
(int) pcb->frame_redline,
(int) pcb->frame_pointer);
fprintf(stderr, "returning ... \n");
*/
page_t* p = malloc(sizeof(page_t));
if(p == NULL){
fprintf(stderr, "cannot malloc page_t\n");
exit(-1);
}
p->base = stack_top;
p->end = stack_top + stack_size;
p->next = (page_t*) pcb->string_pages;
pcb->string_pages = (char*) p;
return;
}
/*
On overflow:
+--------------+
| unused |
| area |
| |
+--------------+
| rp | <-- frame pointer on overflow
+--------------+
| frame |
| when |
| overflow |
| occured |
+--------------+
| rp_next | <-- capture next conitnuation here
+--------------+ (unless we're at base already)
| ... |
| ... |
| ... |
+--------------+
| underflow |
+--------------+
New stack:
+--------------+
| unused |
| area |
| |
| |
| |
| |
| |
| |
| |
| |
+--------------+
| rp | <-- frame pointer on return
+--------------+
| frame |
| when |
| overflow |
| occured |
+--------------+
| underflow |
+--------------+
*/

804
src/collect-5.6.c Normal file
View File

@ -0,0 +1,804 @@
#include <stdio.h>
#include <stdint.h>
#include <stdlib.h>
#include <string.h>
#include <sys/mman.h>
#include <assert.h>
#include "scheme.h"
typedef struct root_t{
int count;
char** start;
struct root_t* next;
} root_t;
void S_add_roots(pcb_t* pcb, int* f){
int n = *f;
if(n == 0) return;
root_t* t = malloc(sizeof(root_t));
if(t == NULL){
fprintf(stderr, "Error mallocing\n");
exit(-1);
}
t->count = n;
t->start = (char**)(f+1);
t->next = (root_t*) pcb->roots;
pcb->roots = (char*) t;
int i;
for(i=1; i<=n; i++){
assert(f[i] == 0);
}
}
void S_check_roots(pcb_t* pcb, int* f){
int n = *f;
int i;
for(i=1; i<=n; i++){
assert(f[i] != 0);
}
}
/* S_collect is called from scheme under the following conditions:
* 1. An attempt is made to allocate a small object and the ap is above
* the red line.
* 2. The current frame of the call is dead, so, upon return from S_collect,
* the caller returns to its caller.
* 3. The frame-pointer of the caller to S_collect is saved at
* pcb->stack_extent. No variables are live at that frame except for
* the return point (at *(pcb->stack_extent)).
* 4. S_collect must return a new ap (in pcb->allocation_pointer) that has
* at least 2 pages of memory free.
* 5. S_collect must also update pcb->allocaton_red_line to be 2 pages below
* the real end of heap.
* 6. S_collect should not move the stack.
*/
#define pagesize 4096
#define pageshift 12
#define minimum_heap_size (pagesize * 1024 * 4)
#define maximum_heap_size (pagesize * 1024 * 8)
#define minimum_stack_size (pagesize * 128)
#define align_to_page(x) (((x)/pagesize)*pagesize)
#define align_to_next_page(x) \
(((pagesize - 1 + (unsigned int)(x)) >> pageshift) << pageshift)
#define align_to_prev_page(x) \
((((unsigned int)(x)) >> pageshift) << pageshift)
static char* allocate_unprotected_space(int size);
static void deallocate_unprotected_space(char* p, int size);
static void deallocate_string_pages(char*);
static void copy_roots(pcb_t* pcb);
static char* move_object(char* x, pcb_t* pcb);
pcb_t* S_collect(int req, pcb_t* pcb){
#if 0
fprintf(stderr, "S_collect entry %d (pcb=0x%08x)\n", req, (int)pcb);
#endif
char* heap_base = pcb->heap_base;
#if 0
int heap_size = (int)pcb->heap_size;
fprintf(stderr, "heapsize=0x%08x (0x%08x .. 0x%08x)\n",
heap_size,
(int) heap_base,
(int) (heap_base + heap_size - 1));
#endif
int used_space = (int)(pcb->allocation_pointer - heap_base);
{
int bytes = (int) pcb->allocated_bytes + (used_space & 0xFFFFF);
pcb->allocated_megs += (bytes >> 20);
pcb->allocated_bytes = (char*) (bytes & 0xFFFFF);
#if 0
fprintf(stderr, "allocated %d megs and %d bytes so far\n",
(int) pcb->allocated_megs,
(int) pcb->allocated_bytes);
#endif
}
int required_space = align_to_page(used_space + 2 * req + 2 * pagesize);
if(required_space < minimum_heap_size){
required_space = minimum_heap_size;
}
if(required_space > maximum_heap_size){
fprintf(stderr, "Maximum heapsize exceeded\n");
exit(-1);
}
char* old_heap = pcb->heap_base;
int old_size = (int)pcb->heap_size;
char* old_string_pages = pcb->string_pages;
pcb->string_pages = 0;
char* new_heap = allocate_unprotected_space(maximum_heap_size);
pcb->allocation_pointer = new_heap;
pcb->allocation_redline = new_heap + maximum_heap_size - 2 * pagesize;
pcb->heap_base = new_heap;
pcb->heap_size = (char*) maximum_heap_size;
copy_roots(pcb);
char** p = (char**) new_heap;
while(p != (char**) pcb->allocation_pointer){
*p = move_object(*p, pcb);
p++;
}
deallocate_unprotected_space(old_heap, old_size);
deallocate_string_pages(old_string_pages);
{
int free_space =
(int)pcb->allocation_redline - (int)pcb->allocation_pointer;
int diff = align_to_page(free_space - minimum_heap_size);
if(diff > 0){
deallocate_unprotected_space(
pcb->heap_base + (int)pcb->heap_size - diff,
diff);
pcb->allocation_redline -= diff;
pcb->heap_size -= diff;
}
}
#if 0
fprintf(stderr, "ap=0x%08x limit=0x%08x\n",
(int)pcb->allocation_pointer,
(int)pcb->heap_base+(int)pcb->heap_size-wordsize);
#endif
return pcb;
}
#define fixnump(x) ((((int)(x)) & fx_mask) == fx_tag)
#define closurep(x) ((((int)(x)) & closure_mask) == closure_tag)
#define immediatep(x) ((((int)(x)) & 7) == 7)
#define tagof(x) (((int) (x)) & 7)
#define ref(x,t) (*((char**)(((char*)(x))+((int)(t)))))
#define align(x) ((((x)+object_alignment-1)>>align_shift)<<align_shift)
typedef struct page_t{
char* base;
char* end;
struct page_t* next;
} page_t;
static page_t* make_page_t(){
page_t* p = malloc(sizeof(page_t));
if(p == NULL){
fprintf(stderr, "failed to allocate page");
exit(-1);
}
return p;
}
static void deallocate_string_pages(char* old_string_pages){
page_t* p;
p = (page_t*) old_string_pages;
while(p){
deallocate_unprotected_space(p->base, p->end - p->base);
p=p->next;
}
p = (page_t*) old_string_pages;
while(p){
page_t* n = p->next;
free(p);
p = n;
}
}
#if 0
static char* extend_pointer_ap(pcb_t* pcb, int size){
if(pcb->pointer_base){
page_t* p = make_page_t();
p->base = pcb->pointer_base;
p->end = pcb->pointer_ap;
p->next = (page_t*) pcb->pointer_pages;
pcb->pointer_pages = (char*) p;
}
char* ap = allocate_unprotected_space(size);
pcb->pointer_base = ap;
pcb->pointer_ap = ap;
pcb->pointer_eap = ap + size;
return ap;
}
#endif
static char* alloc_large_string(pcb_t* pcb, int size){
char* ap = allocate_unprotected_space(size);
page_t* p = make_page_t();
p->base = ap;
p->end = ap+size;
p->next = (page_t*) pcb->string_pages;
pcb->string_pages = (char*) p;
return ap;
}
static char* extend_string_ap(pcb_t* pcb, int size){
if(pcb->string_base){
page_t* p = make_page_t();
p->base = pcb->string_base;
p->end = pcb->string_ap;
p->next = (page_t*) pcb->string_pages;
pcb->string_pages = (char*) p;
}
char* ap = allocate_unprotected_space(size);
pcb->string_base = ap;
pcb->string_ap = ap;
pcb->string_eap = ap + size;
return ap;
}
static char* move_string(char* s, pcb_t* pcb){
int len = (int) ref(s, -string_tag);
int sz = align((len>>fx_shift)+disp_string_data+1);
if(sz < pagesize){
char* ap = pcb->string_ap;
char* nap = ap + sz;
if(nap > pcb->string_eap){
ap = extend_string_ap(pcb, pagesize);
pcb->string_eap = ap + pagesize;
nap = ap + sz;
}
pcb->string_ap = nap;
memcpy(ap, s-string_tag, sz);
ref(s,-string_tag) = (char*)-1;
ref(s,wordsize-string_tag) = ap+string_tag;
return ap + string_tag;
}
else {
char* ap = alloc_large_string(pcb, sz);
memcpy(ap, s-string_tag, sz);
ref(s,-string_tag) = (char*)-1;
ref(s,wordsize-string_tag) = ap+string_tag;
return ap + string_tag;
}
}
static void munch_stack(char* fp, pcb_t* pcb, char* frame_base){
while(fp != frame_base){
assert(fp < frame_base);
#if 0
fprintf(stderr, "copying frame at 0x%08x of 0x%08x\n",
(int)fp, (int)stack_base);
#endif
char* rp = ref(fp, 0);
#if 0
fprintf(stderr, "return-point = 0x%08x\n", (int)rp);
#endif
int framesize = (int) ref(rp, disp_frame_size); /* UGLY */
assert(fixnump(framesize));
assert(framesize >= 0);
if(framesize > 0){
int bytes_in_mask = ((framesize>>fx_shift)+7)>>3;
char* mask = rp + disp_frame_size - bytes_in_mask;
fp = fp + framesize;
char** fpp = (char**) fp;
int i;
for(i=0; i<bytes_in_mask; i++){
unsigned char m = mask[i];
if(m){
if (m & 0x01) {
fpp[0] = move_object(fpp[0], pcb);
}
if (m & 0x02) {
fpp[-1] = move_object(fpp[-1], pcb);
}
if (m & 0x04) {
fpp[-2] = move_object(fpp[-2], pcb);
}
if (m & 0x08) {
fpp[-3] = move_object(fpp[-3], pcb);
}
if (m & 0x10) {
fpp[-4] = move_object(fpp[-4], pcb);
}
if (m & 0x20) {
fpp[-5] = move_object(fpp[-5], pcb);
}
if (m & 0x40) {
fpp[-6] = move_object(fpp[-6], pcb);
}
if (m & 0x80) {
fpp[-7] = move_object(fpp[-7], pcb);
}
}
fpp -= 8;
}
}
else if(framesize == 0){
framesize = (int)ref(fp, wordsize);
assert(fixnump(framesize));
assert(framesize > 0);
#if 0
/* move cp */
{
char* cp = ref(fp, 2*wordsize);
assert(closurep(cp));
ref(fp, 2*wordsize) = move_object(cp, pcb);
}
#endif
fp += framesize;
int i;
for(i=wordsize; i<(framesize); i+=wordsize){
ref(fp, -i) = move_object(ref(fp,-i), pcb);
}
}
else {
fprintf(stderr, "Error: framesize is %d\n", framesize);
exit(-10);
}
}
}
static char* move_stack(char* s, pcb_t* pcb, int sz){
char* ns;
int asz = align(sz);
if(asz < pagesize){
char* ap = pcb->string_ap;
char* nap = ap + asz;
if(nap > pcb->string_eap){
ap = extend_string_ap(pcb, pagesize);
pcb->string_eap = ap + pagesize;
nap = ap + asz;
}
pcb->string_ap = nap;
ns = ap;
}
else {
ns = alloc_large_string(pcb, asz);
}
memcpy(ns, s, sz);
munch_stack(ns, pcb, ns+sz);
return ns;
}
static char* move_pointers(char* x, pcb_t* pcb, int size, int tag){
int sz = align(size);
char* ap = pcb->allocation_pointer;
char* nap = ap + sz;
pcb->allocation_pointer = nap;
ref(nap, -wordsize) = 0;
memcpy(ap, x, size);
ref(x,0) = (char*)-1;
ref(x,wordsize) = ap + tag;
return ap + tag;
}
static char* move_continuation(char* x, pcb_t* pcb){
int sz = (int) ref(x, disp_continuation_size);
char* top = ref(x, disp_continuation_top);
char* r = move_pointers(x, pcb, continuation_size, vector_tag);
ref(r, disp_continuation_top - vector_tag) = move_stack(top, pcb, sz);
return r;
}
static char* move_code(char* x, pcb_t* pcb){
int instrsize = (int) ref(x, disp_code_instrsize);
if(instrsize == 0){
return (x + vector_tag);
}
int relocsize = (int) ref(x, disp_code_relocsize);
int reqspace = instrsize + relocsize + disp_code_data;
char* nx = allocate_unprotected_space(reqspace);
{
page_t* p = malloc(sizeof(page_t));
if(p == NULL){
fprintf(stderr, "failed to alloc a page_t\n");
exit(-1);
}
p->next = (page_t*) pcb->string_pages;
pcb->string_pages = (char*) p;
p->base = nx;
p->end = nx + reqspace;
}
memcpy(nx, x, reqspace);
ref(x, 0) = (char*)-1;
ref(x, wordsize) = nx + vector_tag;
{
char* p = nx + disp_code_data + instrsize;
char* pe = p + relocsize;
while(p < pe){
int r = (int) ref(p,0);
if(r == 0){
p = pe;
}
else {
int rtag = r & 3;
if(rtag == 0){
/* undisplaced pointer */
int code_offset = r >> 2;
char* old_object = ref(nx, disp_code_data + code_offset);
char* new_object = move_object(old_object, pcb);
ref(nx, disp_code_data + code_offset) = new_object;
p += wordsize;
}
else if(rtag == 1){
/* displaced pointer */
int code_offset = r >> 2;
int object_offset = (int) ref(p, wordsize);
char* old_displaced_object = ref(nx, disp_code_data + code_offset);
char* old_object = old_displaced_object - object_offset;
char* new_object = move_object(old_object, pcb);
char* new_displaced_object = new_object + object_offset;
ref(nx, disp_code_data + code_offset) = new_displaced_object;
p += (2 * wordsize);
}
else if(rtag == 2){
/* displaced relative pointer */
int code_offset = r >> 2;
int relative_offset = (int) ref(p, wordsize);
char* old_relative_pointer = ref(nx, disp_code_data + code_offset);
char* old_relative_object = old_relative_pointer - relative_offset;
char* old_addr = x + disp_code_data + code_offset + wordsize;
char* old_object = old_relative_object + (unsigned int) old_addr;
char* new_object = move_object(old_object, pcb);
char* new_disp_object = new_object + relative_offset;
char* next_word = nx + disp_code_data + code_offset + wordsize;
char* new_relative_pointer =
new_disp_object - (unsigned int) next_word;
ref(next_word, -wordsize) = new_relative_pointer;
p += (2 * wordsize);
}
else {
fprintf(stderr, "invalid rtag %d in 0x%08x\n", rtag, r);
exit(-1);
}
}
}
}
int err = mprotect(nx,
align_to_next_page(reqspace),
PROT_READ | PROT_WRITE | PROT_EXEC);
if(err == -1){
perror("Cannot set code executable");
exit(-1);
}
return nx + vector_tag;
}
static char* move_object(char* x, pcb_t* pcb){
if(fixnump(x)){
return x;
}
else if(immediatep(x)){
return x;
}
else {
int tag = tagof(x);
char* fst = ref(x, -tag);
if(fst == (char*)-1){
return ref(x,wordsize-tag);
}
else if(tag == pair_tag){
return(move_pointers(x-tag, pcb, pair_size, tag));
}
else if(tag == closure_tag){
//assert(ref(fst, -2*wordsize) == 0);
int size = (int) ref(fst, -wordsize);
assert(fixnump(size));
assert(size > 0);
char* new_closure = move_pointers(x-tag, pcb, size, tag);
char* code_entry = ref(new_closure, -closure_tag);
char* code_object = code_entry - disp_code_data + vector_tag;
char* new_code_object = move_object(code_object, pcb);
char* new_code_entry = new_code_object + disp_code_data - vector_tag;
ref(new_closure, -closure_tag) = new_code_entry;
return new_closure;
}
else if(tag == symbol_tag){
return (move_pointers(x-tag, pcb, symbol_size, tag));
}
else if(tag == vector_tag){
if(fixnump(fst)){
return (move_pointers(x-tag, pcb, disp_vector_data + (int)fst, tag));
}
else if(fst == (char*) continuation_tag){
return (move_continuation(x-tag, pcb));
}
else if(fst == (char*) code_tag){
return (move_code(x-tag, pcb));
}
else if(((int)fst & record_pmask) == record_ptag){
int len;
{
char* rtd = fst;
char* rtd_fst = ref(rtd, -record_ptag);
if(rtd_fst == (char*) -1){
rtd = ref(rtd, wordsize-record_ptag);
}
len = (int) ref(rtd, disp_record_data - record_ptag);
}
return (move_pointers(x-tag, pcb, disp_record_data + len, tag));
}
else {
fprintf(stderr, "nonvec 0x%08x 0x%08x\n", (int)x, (int)fst);
exit(-1);
}
}
else if(tag == string_tag){
return (move_string(x, pcb));
}
else {
fprintf(stderr, "here tag=%d\n", tag);
exit(-1);
}
}
}
static void copy_roots(pcb_t* pcb){
/* first, the constants */
root_t* r = (root_t*)pcb->roots;
while(r){
int n = r->count;
char** f = r->start;
int i;
for(i=0; i<n; i++){
f[i] = move_object(f[i], pcb);
}
r = r->next;
}
/* next, the pcb-primitives */
char** fst = &pcb->scheme_objects;
char** end = &pcb->scheme_objects_end;
fst++;
while(fst < end){
*fst = move_object(*fst, pcb);
fst++;
}
/* next, the stack */
char* fp = pcb->frame_pointer;
char* frame_base = pcb->frame_base;
munch_stack(fp, pcb, frame_base);
}
static char* allocate_unprotected_space(int size){
int aligned_size = ((size + pagesize - 1) / pagesize) * pagesize;
char* p = mmap(0, aligned_size,
PROT_READ | PROT_WRITE,
MAP_ANONYMOUS | MAP_PRIVATE,
0, 0);
if(p == MAP_FAILED){
perror("allocate_unprotected_space failed to mmap");
exit(-10);
}
return p;
}
static void deallocate_unprotected_space(char* p, int size){
int status;
int aligned_size = ((size + pagesize - 1) / pagesize) * pagesize;
status = munmap(p, aligned_size);
if(status != 0){
perror("deallocate_unprotected_space failed to unmap");
exit(-10);
}
}
void S_stack_overflow(pcb_t* pcb){
// fprintf(stderr, "stack overflow detected\n");
char* stack_top = pcb->stack_top;
int stack_size = (int) pcb->stack_size;
char* fp = pcb->frame_pointer;
char* frame_base = pcb->frame_base;
assert(fp != frame_base);
char* rp = ref(fp, 0);
int framesize = (int) ref(rp, disp_frame_size); /* UGLY */
assert(fixnump(framesize));
assert(framesize >= 0);
if(framesize == 0){
framesize = (int)ref(fp, wordsize);
assert(fixnump(framesize));
}
// fprintf(stderr, "framesize = %d bytes\n", framesize);
{ /* capture continuation */
char* next_frame_top = fp + framesize;
if(next_frame_top == frame_base){
fprintf(stderr, "continuation already captured\n");
} else {
//fprintf(stderr, "capturing continuation ... ");
char* cont = pcb->allocation_pointer;
pcb->allocation_pointer += continuation_size;
ref(cont, 0) = (char*) continuation_tag;
ref(cont, disp_continuation_top) = next_frame_top;
ref(cont, disp_continuation_next) = pcb->next_continuation;
ref(cont, disp_continuation_size) =
frame_base - (int)next_frame_top;
pcb->next_continuation = cont + vector_tag;
//fprintf(stderr, "done (sz=0x%08x)\n",
// (int) ref(cont, disp_continuation_size));
}
}
int req_stack_size = align_to_page(framesize * 4 + 2 * pagesize);
if(req_stack_size < minimum_stack_size){
req_stack_size = minimum_stack_size;
}
char* new_stack = allocate_unprotected_space(req_stack_size);
char* new_frame_redline = new_stack + 2 * pagesize;
char* new_frame_base = new_stack + req_stack_size - wordsize;
ref(new_frame_base, 0) = ref(frame_base, 0); /* underflow handler */
memcpy(new_frame_base - framesize, fp, framesize);
pcb->stack_top = new_stack;
pcb->stack_size = (char*)req_stack_size;
pcb->frame_base = new_frame_base;
pcb->frame_pointer = new_frame_base - framesize;
pcb->frame_redline = new_frame_redline;
/*
fprintf(stderr, "stack=0x%08x .. 0x%08x (redline=0x%08x) fp=0x%08x\n",
(int) pcb->frame_base,
(int) pcb->stack_top,
(int) pcb->frame_redline,
(int) pcb->frame_pointer);
fprintf(stderr, "returning ... \n");
*/
page_t* p = malloc(sizeof(page_t));
if(p == NULL){
fprintf(stderr, "cannot malloc page_t\n");
exit(-1);
}
p->base = stack_top;
p->end = stack_top + stack_size;
p->next = (page_t*) pcb->string_pages;
pcb->string_pages = (char*) p;
//fprintf(stderr, "done\n");
return;
}
/*
On overflow:
+--------------+
| unused |
| area |
| |
+--------------+
| rp | <-- frame pointer on overflow
+--------------+
| frame |
| when |
| overflow |
| occured |
+--------------+
| rp_next | <-- capture next conitnuation here
+--------------+ (unless we're at base already)
| ... |
| ... |
| ... |
+--------------+
| underflow |
+--------------+
New stack:
+--------------+
| unused |
| area |
| |
| |
| |
| |
| |
| |
| |
| |
+--------------+
| rp | <-- frame pointer on return
+--------------+
| frame |
| when |
| overflow |
| occured |
+--------------+
| underflow |
+--------------+
*/
char* S_make_code(int fxcsize, int fxrsize, int fxclsize, pcb_t* pcb){
int csize = fxcsize >> fx_shift;
csize = (((csize + (1 << fx_shift) - 1) >> fx_shift) << fx_shift);
int reqspace = csize + fxrsize + disp_code_data;
char* code = allocate_unprotected_space(reqspace);
{
page_t* p = malloc(sizeof(page_t));
if(p == NULL){
fprintf(stderr, "failed to allocate a page\n");
exit(-1);
}
p->base = code;
p->end = code + reqspace;
p->next = (page_t*) pcb->string_pages;
pcb->string_pages = (char*) p;
}
memset(code, 0, reqspace);
ref(code, 0) = (char*)code_tag;
ref(code, disp_code_instrsize) = (char*) csize;
ref(code, disp_code_relocsize) = (char*) fxrsize;
ref(code, disp_code_closuresize) = (char*) fxclsize;
return(code + vector_tag);
}
char* S_make_code_executable(char* x, pcb_t* pcb){
int instrsize = (int) ref(x, disp_code_instrsize - vector_tag);
char* code_start = x + disp_code_data - vector_tag;
char* code_end = code_start + instrsize;
char* page_start = (char*) align_to_prev_page(code_start);
char* page_end = (char*) align_to_next_page(code_end);
int err = mprotect(page_start,
(int) (page_end - page_start),
PROT_READ | PROT_WRITE | PROT_EXEC);
if(err == -1){
perror("Cannot set code executable");
exit(-1);
}
return bool_t;
}
#if 0
SUPER FAST HASH
Taken from
http://www.azillionmonkeys.com/qed/hash.html
#endif
#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);
}

839
src/collect-5.7.c Normal file
View File

@ -0,0 +1,839 @@
#include <stdio.h>
#include <stdint.h>
#include <stdlib.h>
#include <unistd.h>
#include <string.h>
#include <sys/mman.h>
#include <sys/types.h>
#include <assert.h>
#include <uuid/uuid.h>
#include "scheme.h"
typedef struct root_t{
int count;
char** start;
struct root_t* next;
} root_t;
void S_add_roots(pcb_t* pcb, int* f){
int n = *f;
if(n == 0) return;
root_t* t = malloc(sizeof(root_t));
if(t == NULL){
fprintf(stderr, "Error mallocing\n");
exit(-1);
}
t->count = n;
t->start = (char**)(f+1);
t->next = (root_t*) pcb->roots;
pcb->roots = (char*) t;
int i;
for(i=1; i<=n; i++){
assert(f[i] == 0);
}
}
void S_check_roots(pcb_t* pcb, int* f){
int n = *f;
int i;
for(i=1; i<=n; i++){
assert(f[i] != 0);
}
}
/* S_collect is called from scheme under the following conditions:
* 1. An attempt is made to allocate a small object and the ap is above
* the red line.
* 2. The current frame of the call is dead, so, upon return from S_collect,
* the caller returns to its caller.
* 3. The frame-pointer of the caller to S_collect is saved at
* pcb->stack_extent. No variables are live at that frame except for
* the return point (at *(pcb->stack_extent)).
* 4. S_collect must return a new ap (in pcb->allocation_pointer) that has
* at least 2 pages of memory free.
* 5. S_collect must also update pcb->allocaton_red_line to be 2 pages below
* the real end of heap.
* 6. S_collect should not move the stack.
*/
#define pagesize 4096
#define pageshift 12
#define minimum_heap_size (pagesize * 1024 * 4)
#define maximum_heap_size (pagesize * 1024 * 8)
#define minimum_stack_size (pagesize * 128)
#define align_to_page(x) (((x)/pagesize)*pagesize)
#define align_to_next_page(x) \
(((pagesize - 1 + (unsigned int)(x)) >> pageshift) << pageshift)
#define align_to_prev_page(x) \
((((unsigned int)(x)) >> pageshift) << pageshift)
static char* allocate_unprotected_space(int size);
static void deallocate_unprotected_space(char* p, int size);
static void deallocate_string_pages(char*);
static void copy_roots(pcb_t* pcb);
static char* move_object(char* x, pcb_t* pcb);
pcb_t* S_collect(int req, pcb_t* pcb){
#if 0
fprintf(stderr, "S_collect entry %d (pcb=0x%08x)\n", req, (int)pcb);
#endif
char* heap_base = pcb->heap_base;
#if 0
int heap_size = (int)pcb->heap_size;
fprintf(stderr, "heapsize=0x%08x (0x%08x .. 0x%08x)\n",
heap_size,
(int) heap_base,
(int) (heap_base + heap_size - 1));
#endif
int used_space = (int)(pcb->allocation_pointer - heap_base);
{
int bytes = (int) pcb->allocated_bytes + (used_space & 0xFFFFF);
pcb->allocated_megs += (bytes >> 20);
pcb->allocated_bytes = (char*) (bytes & 0xFFFFF);
#if 0
fprintf(stderr, "allocated %d megs and %d bytes so far\n",
(int) pcb->allocated_megs,
(int) pcb->allocated_bytes);
#endif
}
int required_space = align_to_page(used_space + 2 * req + 2 * pagesize);
if(required_space < minimum_heap_size){
required_space = minimum_heap_size;
}
if(required_space > maximum_heap_size){
fprintf(stderr, "Maximum heapsize exceeded\n");
exit(-1);
}
char* old_heap = pcb->heap_base;
int old_size = (int)pcb->heap_size;
char* old_string_pages = pcb->string_pages;
pcb->string_pages = 0;
char* new_heap = allocate_unprotected_space(maximum_heap_size);
pcb->allocation_pointer = new_heap;
pcb->allocation_redline = new_heap + maximum_heap_size - 2 * pagesize;
pcb->heap_base = new_heap;
pcb->heap_size = (char*) maximum_heap_size;
copy_roots(pcb);
char** p = (char**) new_heap;
while(p != (char**) pcb->allocation_pointer){
*p = move_object(*p, pcb);
p++;
}
deallocate_unprotected_space(old_heap, old_size);
deallocate_string_pages(old_string_pages);
{
int free_space =
(int)pcb->allocation_redline - (int)pcb->allocation_pointer;
int diff = align_to_page(free_space - minimum_heap_size);
if(diff > 0){
deallocate_unprotected_space(
pcb->heap_base + (int)pcb->heap_size - diff,
diff);
pcb->allocation_redline -= diff;
pcb->heap_size -= diff;
}
}
#if 0
fprintf(stderr, "ap=0x%08x limit=0x%08x\n",
(int)pcb->allocation_pointer,
(int)pcb->heap_base+(int)pcb->heap_size-wordsize);
#endif
return pcb;
}
#define fixnump(x) ((((int)(x)) & fx_mask) == fx_tag)
#define closurep(x) ((((int)(x)) & closure_mask) == closure_tag)
#define immediatep(x) ((((int)(x)) & 7) == 7)
#define tagof(x) (((int) (x)) & 7)
#define ref(x,t) (*((char**)(((char*)(x))+((int)(t)))))
#define align(x) ((((x)+object_alignment-1)>>align_shift)<<align_shift)
typedef struct page_t{
char* base;
char* end;
struct page_t* next;
} page_t;
static page_t* make_page_t(){
page_t* p = malloc(sizeof(page_t));
if(p == NULL){
fprintf(stderr, "failed to allocate page");
exit(-1);
}
return p;
}
static void deallocate_string_pages(char* old_string_pages){
page_t* p;
p = (page_t*) old_string_pages;
while(p){
deallocate_unprotected_space(p->base, p->end - p->base);
p=p->next;
}
p = (page_t*) old_string_pages;
while(p){
page_t* n = p->next;
free(p);
p = n;
}
}
#if 0
static char* extend_pointer_ap(pcb_t* pcb, int size){
if(pcb->pointer_base){
page_t* p = make_page_t();
p->base = pcb->pointer_base;
p->end = pcb->pointer_ap;
p->next = (page_t*) pcb->pointer_pages;
pcb->pointer_pages = (char*) p;
}
char* ap = allocate_unprotected_space(size);
pcb->pointer_base = ap;
pcb->pointer_ap = ap;
pcb->pointer_eap = ap + size;
return ap;
}
#endif
static char* alloc_large_string(pcb_t* pcb, int size){
char* ap = allocate_unprotected_space(size);
page_t* p = make_page_t();
p->base = ap;
p->end = ap+size;
p->next = (page_t*) pcb->string_pages;
pcb->string_pages = (char*) p;
return ap;
}
static char* extend_string_ap(pcb_t* pcb, int size){
if(pcb->string_base){
page_t* p = make_page_t();
p->base = pcb->string_base;
p->end = pcb->string_ap;
p->next = (page_t*) pcb->string_pages;
pcb->string_pages = (char*) p;
}
char* ap = allocate_unprotected_space(size);
pcb->string_base = ap;
pcb->string_ap = ap;
pcb->string_eap = ap + size;
return ap;
}
static char* move_string(char* s, pcb_t* pcb){
int len = (int) ref(s, -string_tag);
int sz = align((len>>fx_shift)+disp_string_data+1);
if(sz < pagesize){
char* ap = pcb->string_ap;
char* nap = ap + sz;
if(nap > pcb->string_eap){
ap = extend_string_ap(pcb, pagesize);
pcb->string_eap = ap + pagesize;
nap = ap + sz;
}
pcb->string_ap = nap;
memcpy(ap, s-string_tag, sz);
ref(s,-string_tag) = (char*)-1;
ref(s,wordsize-string_tag) = ap+string_tag;
return ap + string_tag;
}
else {
char* ap = alloc_large_string(pcb, sz);
memcpy(ap, s-string_tag, sz);
ref(s,-string_tag) = (char*)-1;
ref(s,wordsize-string_tag) = ap+string_tag;
return ap + string_tag;
}
}
static void munch_stack(char* fp, pcb_t* pcb, char* frame_base){
while(fp != frame_base){
assert(fp < frame_base);
#if 0
fprintf(stderr, "copying frame at 0x%08x of 0x%08x\n",
(int)fp, (int)stack_base);
#endif
char* rp = ref(fp, 0);
#if 0
fprintf(stderr, "return-point = 0x%08x\n", (int)rp);
#endif
char* rp_offset = ref(rp, disp_frame_offset);
assert(rp_offset == 0);
int framesize = (int) ref(rp, disp_frame_size); /* UGLY */
assert(fixnump(framesize));
assert(framesize >= 0);
if(framesize > 0){
int bytes_in_mask = ((framesize>>fx_shift)+7)>>3;
char* mask = rp + disp_frame_size - bytes_in_mask;
fp = fp + framesize;
char** fpp = (char**) fp;
int i;
for(i=0; i<bytes_in_mask; i++){
unsigned char m = mask[i];
if(m){
if (m & 0x01) {
fpp[0] = move_object(fpp[0], pcb);
}
if (m & 0x02) {
fpp[-1] = move_object(fpp[-1], pcb);
}
if (m & 0x04) {
fpp[-2] = move_object(fpp[-2], pcb);
}
if (m & 0x08) {
fpp[-3] = move_object(fpp[-3], pcb);
}
if (m & 0x10) {
fpp[-4] = move_object(fpp[-4], pcb);
}
if (m & 0x20) {
fpp[-5] = move_object(fpp[-5], pcb);
}
if (m & 0x40) {
fpp[-6] = move_object(fpp[-6], pcb);
}
if (m & 0x80) {
fpp[-7] = move_object(fpp[-7], pcb);
}
}
fpp -= 8;
}
}
else if(framesize == 0){
framesize = (int)ref(fp, wordsize);
assert(fixnump(framesize));
assert(framesize > 0);
#if 0
/* move cp */
{
char* cp = ref(fp, 2*wordsize);
assert(closurep(cp));
ref(fp, 2*wordsize) = move_object(cp, pcb);
}
#endif
fp += framesize;
int i;
for(i=wordsize; i<(framesize); i+=wordsize){
ref(fp, -i) = move_object(ref(fp,-i), pcb);
}
}
else {
fprintf(stderr, "Error: framesize is %d\n", framesize);
exit(-10);
}
}
}
static char* move_stack(char* s, pcb_t* pcb, int sz){
char* ns;
int asz = align(sz);
if(asz < pagesize){
char* ap = pcb->string_ap;
char* nap = ap + asz;
if(nap > pcb->string_eap){
ap = extend_string_ap(pcb, pagesize);
pcb->string_eap = ap + pagesize;
nap = ap + asz;
}
pcb->string_ap = nap;
ns = ap;
}
else {
ns = alloc_large_string(pcb, asz);
}
memcpy(ns, s, sz);
munch_stack(ns, pcb, ns+sz);
return ns;
}
static char* move_pointers(char* x, pcb_t* pcb, int size, int tag){
int sz = align(size);
char* ap = pcb->allocation_pointer;
char* nap = ap + sz;
pcb->allocation_pointer = nap;
ref(nap, -wordsize) = 0;
memcpy(ap, x, size);
ref(x,0) = (char*)-1;
ref(x,wordsize) = ap + tag;
return ap + tag;
}
static char* move_continuation(char* x, pcb_t* pcb){
int sz = (int) ref(x, disp_continuation_size);
char* top = ref(x, disp_continuation_top);
char* r = move_pointers(x, pcb, continuation_size, vector_tag);
ref(r, disp_continuation_top - vector_tag) = move_stack(top, pcb, sz);
return r;
}
static char* move_code(char* x, pcb_t* pcb){
int instrsize = (int) ref(x, disp_code_instrsize);
if(instrsize == 0){
return (x + vector_tag);
}
int relocsize = (int) ref(x, disp_code_relocsize);
int reqspace = instrsize + relocsize + disp_code_data;
char* nx = allocate_unprotected_space(reqspace);
{
page_t* p = malloc(sizeof(page_t));
if(p == NULL){
fprintf(stderr, "failed to alloc a page_t\n");
exit(-1);
}
p->next = (page_t*) pcb->string_pages;
pcb->string_pages = (char*) p;
p->base = nx;
p->end = nx + reqspace;
}
memcpy(nx, x, reqspace);
ref(x, 0) = (char*)-1;
ref(x, wordsize) = nx + vector_tag;
{
char* p = nx + disp_code_data + instrsize;
char* pe = p + relocsize;
while(p < pe){
int r = (int) ref(p,0);
if(r == 0){
p = pe;
}
else {
int rtag = r & 3;
if(rtag == 0){
/* undisplaced pointer */
int code_offset = r >> 2;
char* old_object = ref(nx, disp_code_data + code_offset);
char* new_object = move_object(old_object, pcb);
ref(nx, disp_code_data + code_offset) = new_object;
p += wordsize;
}
else if(rtag == 1){
/* displaced pointer */
int code_offset = r >> 2;
int object_offset = (int) ref(p, wordsize);
char* old_displaced_object = ref(nx, disp_code_data + code_offset);
char* old_object = old_displaced_object - object_offset;
char* new_object = move_object(old_object, pcb);
char* new_displaced_object = new_object + object_offset;
ref(nx, disp_code_data + code_offset) = new_displaced_object;
p += (2 * wordsize);
}
else if(rtag == 2){
/* displaced relative pointer */
int code_offset = r >> 2;
int relative_offset = (int) ref(p, wordsize);
char* old_relative_pointer = ref(nx, disp_code_data + code_offset);
char* old_relative_object = old_relative_pointer - relative_offset;
char* old_addr = x + disp_code_data + code_offset + wordsize;
char* old_object = old_relative_object + (unsigned int) old_addr;
char* new_object = move_object(old_object, pcb);
char* new_disp_object = new_object + relative_offset;
char* next_word = nx + disp_code_data + code_offset + wordsize;
char* new_relative_pointer =
new_disp_object - (unsigned int) next_word;
ref(next_word, -wordsize) = new_relative_pointer;
p += (2 * wordsize);
}
else {
fprintf(stderr, "invalid rtag %d in 0x%08x\n", rtag, r);
exit(-1);
}
}
}
}
int err = mprotect(nx,
align_to_next_page(reqspace),
PROT_READ | PROT_WRITE | PROT_EXEC);
if(err == -1){
perror("Cannot set code executable");
exit(-1);
}
return nx + vector_tag;
}
static char* move_object(char* x, pcb_t* pcb){
if(fixnump(x)){
return x;
}
else if(immediatep(x)){
return x;
}
else {
int tag = tagof(x);
char* fst = ref(x, -tag);
if(fst == (char*)-1){
return ref(x,wordsize-tag);
}
else if(tag == pair_tag){
return(move_pointers(x-tag, pcb, pair_size, tag));
}
else if(tag == closure_tag){
//assert(ref(fst, -2*wordsize) == 0);
int size = (int) ref(fst, -wordsize);
assert(fixnump(size));
assert(size > 0);
char* new_closure = move_pointers(x-tag, pcb, size, tag);
char* code_entry = ref(new_closure, -closure_tag);
char* code_object = code_entry - disp_code_data + vector_tag;
char* new_code_object = move_object(code_object, pcb);
char* new_code_entry = new_code_object + disp_code_data - vector_tag;
ref(new_closure, -closure_tag) = new_code_entry;
return new_closure;
}
else if(tag == symbol_tag){
return (move_pointers(x-tag, pcb, symbol_size, tag));
}
else if(tag == vector_tag){
if(fixnump(fst)){
return (move_pointers(x-tag, pcb, disp_vector_data + (int)fst, tag));
}
else if(fst == (char*) continuation_tag){
return (move_continuation(x-tag, pcb));
}
else if(fst == (char*) code_tag){
return (move_code(x-tag, pcb));
}
else if(((int)fst & record_pmask) == record_ptag){
int len;
{
char* rtd = fst;
char* rtd_fst = ref(rtd, -record_ptag);
if(rtd_fst == (char*) -1){
rtd = ref(rtd, wordsize-record_ptag);
}
len = (int) ref(rtd, disp_record_data - record_ptag);
}
return (move_pointers(x-tag, pcb, disp_record_data + len, tag));
}
else {
fprintf(stderr, "nonvec 0x%08x 0x%08x\n", (int)x, (int)fst);
exit(-1);
}
}
else if(tag == string_tag){
return (move_string(x, pcb));
}
else {
fprintf(stderr, "here tag=%d\n", tag);
exit(-1);
}
}
}
static void copy_roots(pcb_t* pcb){
/* first, the constants */
root_t* r = (root_t*)pcb->roots;
while(r){
int n = r->count;
char** f = r->start;
int i;
for(i=0; i<n; i++){
f[i] = move_object(f[i], pcb);
}
r = r->next;
}
/* next, the pcb-primitives */
char** fst = &pcb->scheme_objects;
char** end = &pcb->scheme_objects_end;
fst++;
while(fst < end){
*fst = move_object(*fst, pcb);
fst++;
}
/* next, the stack */
char* fp = pcb->frame_pointer;
char* frame_base = pcb->frame_base;
munch_stack(fp, pcb, frame_base);
}
static char* allocate_unprotected_space(int size){
int aligned_size = ((size + pagesize - 1) / pagesize) * pagesize;
char* p = mmap(0, aligned_size,
PROT_READ | PROT_WRITE,
MAP_ANONYMOUS | MAP_PRIVATE,
0, 0);
if(p == MAP_FAILED){
perror("allocate_unprotected_space failed to mmap");
exit(-10);
}
return p;
}
static void deallocate_unprotected_space(char* p, int size){
int status;
int aligned_size = ((size + pagesize - 1) / pagesize) * pagesize;
status = munmap(p, aligned_size);
if(status != 0){
perror("deallocate_unprotected_space failed to unmap");
exit(-10);
}
}
void S_stack_overflow(pcb_t* pcb){
// fprintf(stderr, "stack overflow detected\n");
char* stack_top = pcb->stack_top;
int stack_size = (int) pcb->stack_size;
char* fp = pcb->frame_pointer;
char* frame_base = pcb->frame_base;
assert(fp != frame_base);
char* rp = ref(fp, 0);
int framesize = (int) ref(rp, disp_frame_size); /* UGLY */
assert(fixnump(framesize));
assert(framesize >= 0);
if(framesize == 0){
framesize = (int)ref(fp, wordsize);
assert(fixnump(framesize));
}
// fprintf(stderr, "framesize = %d bytes\n", framesize);
{ /* capture continuation */
char* next_frame_top = fp + framesize;
if(next_frame_top == frame_base){
fprintf(stderr, "continuation already captured\n");
} else {
//fprintf(stderr, "capturing continuation ... ");
char* cont = pcb->allocation_pointer;
pcb->allocation_pointer += continuation_size;
ref(cont, 0) = (char*) continuation_tag;
ref(cont, disp_continuation_top) = next_frame_top;
ref(cont, disp_continuation_next) = pcb->next_continuation;
ref(cont, disp_continuation_size) =
frame_base - (int)next_frame_top;
pcb->next_continuation = cont + vector_tag;
//fprintf(stderr, "done (sz=0x%08x)\n",
// (int) ref(cont, disp_continuation_size));
}
}
int req_stack_size = align_to_page(framesize * 4 + 2 * pagesize);
if(req_stack_size < minimum_stack_size){
req_stack_size = minimum_stack_size;
}
char* new_stack = allocate_unprotected_space(req_stack_size);
char* new_frame_redline = new_stack + 2 * pagesize;
char* new_frame_base = new_stack + req_stack_size - wordsize;
ref(new_frame_base, 0) = ref(frame_base, 0); /* underflow handler */
memcpy(new_frame_base - framesize, fp, framesize);
pcb->stack_top = new_stack;
pcb->stack_size = (char*)req_stack_size;
pcb->frame_base = new_frame_base;
pcb->frame_pointer = new_frame_base - framesize;
pcb->frame_redline = new_frame_redline;
/*
fprintf(stderr, "stack=0x%08x .. 0x%08x (redline=0x%08x) fp=0x%08x\n",
(int) pcb->frame_base,
(int) pcb->stack_top,
(int) pcb->frame_redline,
(int) pcb->frame_pointer);
fprintf(stderr, "returning ... \n");
*/
page_t* p = malloc(sizeof(page_t));
if(p == NULL){
fprintf(stderr, "cannot malloc page_t\n");
exit(-1);
}
p->base = stack_top;
p->end = stack_top + stack_size;
p->next = (page_t*) pcb->string_pages;
pcb->string_pages = (char*) p;
//fprintf(stderr, "done\n");
return;
}
/*
On overflow:
+--------------+
| unused |
| area |
| |
+--------------+
| rp | <-- frame pointer on overflow
+--------------+
| frame |
| when |
| overflow |
| occured |
+--------------+
| rp_next | <-- capture next conitnuation here
+--------------+ (unless we're at base already)
| ... |
| ... |
| ... |
+--------------+
| underflow |
+--------------+
New stack:
+--------------+
| unused |
| area |
| |
| |
| |
| |
| |
| |
| |
| |
+--------------+
| rp | <-- frame pointer on return
+--------------+
| frame |
| when |
| overflow |
| occured |
+--------------+
| underflow |
+--------------+
*/
char* S_make_code(int fxcsize, int fxrsize, int fxclsize, pcb_t* pcb){
int csize = fxcsize >> fx_shift;
csize = (((csize + (1 << fx_shift) - 1) >> fx_shift) << fx_shift);
int reqspace = csize + fxrsize + disp_code_data;
char* code = allocate_unprotected_space(reqspace);
{
page_t* p = malloc(sizeof(page_t));
if(p == NULL){
fprintf(stderr, "failed to allocate a page\n");
exit(-1);
}
p->base = code;
p->end = code + reqspace;
p->next = (page_t*) pcb->string_pages;
pcb->string_pages = (char*) p;
}
memset(code, 0, reqspace);
ref(code, 0) = (char*)code_tag;
ref(code, disp_code_instrsize) = (char*) csize;
ref(code, disp_code_relocsize) = (char*) fxrsize;
ref(code, disp_code_closuresize) = (char*) fxclsize;
return(code + vector_tag);
}
char* S_make_code_executable(char* x, pcb_t* pcb){
int instrsize = (int) ref(x, disp_code_instrsize - vector_tag);
char* code_start = x + disp_code_data - vector_tag;
char* code_end = code_start + instrsize;
char* page_start = (char*) align_to_prev_page(code_start);
char* page_end = (char*) align_to_next_page(code_end);
int err = mprotect(page_start,
(int) (page_end - page_start),
PROT_READ | PROT_WRITE | PROT_EXEC);
if(err == -1){
perror("Cannot set code executable");
exit(-1);
}
return bool_t;
}
#if 0
SUPER FAST HASH
Taken from
http://www.azillionmonkeys.com/qed/hash.html
#endif
#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);
}
char* S_uuid(char* str){
assert((36 << fx_shift) == (int) ref(str, disp_string_length - string_tag));
uuid_t u;
uuid_clear(u);
uuid_generate(u);
uuid_unparse_upper(u, str + disp_string_data - string_tag);
return str;
}
char* S_fork(){
pid_t pid = fork();
int fxpid = pid << fx_shift;
if(pid != (fxpid >> fx_shift)){
fprintf(stderr, "BUG: pid out of range in fork\n");
exit(-1);
}
return (char*) fxpid;
}
char* S_system(char* str){
int status = system(str + disp_string_data - string_tag);
int fxstatus = status << fx_shift;
if(status != (fxstatus >> fx_shift)){
fprintf(stderr, "BUG: rv out of range in system\n");
exit(-1);
}
return (char*) fxstatus;
}

2351
src/compiler-5.1.ss Normal file
View File

File diff suppressed because it is too large Load Diff

2729
src/compiler-5.2.ss Normal file
View File

File diff suppressed because it is too large Load Diff

3188
src/compiler-5.3.ss Normal file
View File

File diff suppressed because it is too large Load Diff

3216
src/compiler-5.4.ss Normal file
View File

File diff suppressed because it is too large Load Diff

3568
src/compiler-5.5.ss Normal file
View File

File diff suppressed because it is too large Load Diff

4015
src/compiler-5.6.ss Normal file
View File

File diff suppressed because it is too large Load Diff

3826
src/compiler-5.7.ss Normal file
View File

File diff suppressed because it is too large Load Diff

3840
src/compiler-5.8.ss Normal file
View File

File diff suppressed because it is too large Load Diff

3833
src/compiler-5.9.ss Normal file
View File

File diff suppressed because it is too large Load Diff

24
src/core-syntax.ss Normal file
View File

@ -0,0 +1,24 @@
(module core-syntax (if lambda letrec or let)
(define-syntax if (getprop 'if '*sc-expander*))
(define-syntax lambda (getprop 'lambda '*sc-expander*))
(define-syntax letrec (getprop 'letrec '*sc-expander*))
(define-syntax or
(lambda (x)
(syntax-case x ()
((_) (syntax #f))
((_ e) (syntax e))
((_ e1 e2 e3 ...)
(syntax (let ((t e1)) (if t t (or e2 e3 ...))))))))
(define-syntax let
(lambda (x)
(syntax-case x ()
((_ ((x v) ...) e1 e2 ...)
(andmap identifier? (syntax (x ...)))
(syntax ((lambda (x ...) e1 e2 ...) v ...)))
((_ f ((x v) ...) e1 e2 ...)
(andmap identifier? (syntax (f x ...)))
(syntax ((letrec ((f (lambda (x ...) e1 e2 ...))) f)
v ...))))))
)

42835
src/dump Normal file
View File

File diff suppressed because it is too large Load Diff

12
src/dynamic-load/Makefile Normal file
View File

@ -0,0 +1,12 @@
all: library1.so library2.so client
library1.so: library1.c
gcc -Wall -shared -o library1.so library1.c
library2.so: library2.c
gcc -Wall -shared -o library2.so library2.c
client: client.c
gcc -Wall -ldl -o client client.c

BIN
src/dynamic-load/client Executable file
View File

Binary file not shown.

36
src/dynamic-load/client.c Normal file
View File

@ -0,0 +1,36 @@
#include <stdio.h>
#include <stdlib.h>
#include <dlfcn.h>
void do_lib(char* libname){
fprintf(stderr, "loading %s... ", libname);
void* dh = dlopen(libname, RTLD_NOW | RTLD_LOCAL);
if(dh == NULL){
fprintf(stderr, "failed: %s\n", dlerror());
exit(-1);
}
fprintf(stderr, "0x%08x\n", (int)dh);
fprintf(stderr, "loading library_print ... ");
int(*my_print)(char*) = dlsym(dh, "library_print");
if(my_print == NULL){
fprintf(stderr, "failed: %s\n", dlerror());
exit(-1);
}
fprintf(stderr, "0x%08x\n", (int)my_print);
fprintf(stderr, "Calling it ... ");
my_print("Hello There");
fprintf(stderr, "done\n");
}
int main(int argc, char** argv){
do_lib("./library1.so");
do_lib("./library2.so");
do_lib("./library1.so");
return 0;
}

8
src/dynamic-load/library1.c Normal file
View File

@ -0,0 +1,8 @@
#include <stdio.h>
int library_print(char* x){
fprintf(stderr, "LIB1: %s\n", x);
return 0;
}

8
src/dynamic-load/library2.c Normal file
View File

@ -0,0 +1,8 @@
#include <stdio.h>
int library_print(char* x){
fprintf(stderr, "LIB2: %s\n", x);
return 0;
}

68
src/expand.ss Normal file
View File

@ -0,0 +1,68 @@
(let ()
(define self-evaluating?
(lambda (x)
(or (fixnum? x) (immediate? x))))
(define syntax-error
(lambda (x)
(error 'expand "invalid syntax ~s" x)))
(define build-quoted-constant
(lambda (x)
(list 'quote x)))
(define build-application
(lambda (rator rand*)
(list 'funcall rator rand*)))
(define empty-env
(lambda () '()))
(define Etop
(lambda (expression global-environment)
(define lookup
(lambda (sym env ctxt)
(cond
[(assq sym env) => cdr]
[(getprop sym (environment-key global-environment))]
[(environment-mutable? global-environment)
(define E
(lambda (x env)
(cond
[(self-evaluating? x)
(build-quoted-constant x)]
[(pair? x)
(let ([a (car x)] [d (cdr x)])
(cond
[(symbol? a)
(let ([b (lookup a env x)])
(case (binding-type b)
[else (bug "invalid binding ~s" b)]))]
[(list? d)
(build-application
(E a env)
(map (lambda (x) (E x env)) d))]
[else (syntax-error x)]))]
[else (syntax-error x)])))
(E expression (empty-env))))
(define env-rtd (make-record-type "environment" '(mutable? key)))
(define environment? (record-predicate env-rtd))
(define environment-mutable? (record-field-accessor env-rtd 0))
(define environment-key (record-field-accessor env-rtd 1))
(define make-environment (record-constructor env-rtd))
(define expand
(lambda (x env)
(unless (environment? env)
(error 'expand "~s is not an environment" env))
(Etop x env)))
)

0
src/foo.ss Normal file
View File

47
src/generate-libxcr.ss Normal file
View File

@ -0,0 +1,47 @@
(define generate-cxr-definitions
(lambda ()
(define gen-body
(lambda (name arg ls)
(cond
[(null? (cdr ls))
`(if (pair? ,arg)
(,(car ls) ,arg)
(err ',name orig))]
[else
(let ([a (car ls)])
`(if (pair? ,arg)
(let ([x (,a ,arg)])
,(gen-body name 'x (cdr ls)))
(err ',name orig)))])))
(define gen-cxr
(lambda (name ls)
`($pcb-set! ,name (lambda (orig) ,(gen-body name 'orig ls)))))
(define gen-names-n
(lambda (n)
(cond
[(fx= n 0) '(())]
[else
(let ([ls (gen-names-n (fx- n 1))])
(append
(map (lambda (x) (cons #\a x)) ls)
(map (lambda (x) (cons #\d x)) ls)))])))
(define gen-names
(lambda (n)
(cond
[(fx= n 0) '()]
[else (append (gen-names (fx- n 1)) (gen-names-n n))])))
(define ls->name
(lambda (ls)
(string->symbol (list->string (append '(#\c) ls '(#\r))))))
(define ls->functions
(lambda (ls)
(reverse
(map (lambda (c) (string->symbol (format "$c~ar" c))) ls))))
`(let ([err
(lambda (who x)
(error who "invalid list structure ~s" x))])
,@(map
(lambda (ls) (gen-cxr (ls->name ls) (ls->functions ls)))
(gen-names 4)))))

6
src/geninstr/Makefile Normal file
View File

@ -0,0 +1,6 @@
all:
./gen.pl > tmp.s
gcc -o tmp.o -c tmp.s
objdump -d tmp.o > tmp.dump

86
src/geninstr/gen.pl Executable file
View File

@ -0,0 +1,86 @@
#!/usr/bin/perl -w
my @regs =
('%eax', '%ecx', '%edx', '%ebx', '%esp', '%ebp', '%esi', '%edi');
print ".text\n";
sub gen1{
my $tmpl = shift;
foreach my $r1 (@regs){
my $x = $tmpl;
$x =~ s/r1/$r1/g;
print $x;
}
}
sub gen2{
my $tmpl = shift;
foreach my $r1 (@regs){
foreach my $r2 (@regs){
my $x = $tmpl;
$x =~ s/r1/$r1/g;
$x =~ s/r2/$r2/g;
print $x;
}
}
}
print "sete %al\n";
print "sete %cl\n";
print "sete %dl\n";
print "sete %bl\n";
print "sete %ah\n";
print "sete %ch\n";
print "sete %dh\n";
print "sete %bh\n";
#gen1 "pop r1\n";
#gen1 "pop 12(r1)\n";
#gen1 "pop 10000(r1)\n";
#print "pushl \$0x5\n";
#print "pushl \$0x500\n";
#gen1 "pushl r1\n";
#gen1 "pushl 1(r1)\n";
#gen1 "pushl 1000(r1)\n";
#gen2 "orl 12(r2), r1\n";
#gen1 "orl \$0x400, r1\n";
#gen1 "cmpl \$0x4, r1\n";
#gen2 "cmpl 12(r2), r1\n";
#gen1 "cmpl \$0x400, 12(r1)\n";
#gen1 "cmpl \$0x4, 12000(r1)\n";
#gen1 "cmpl \$0x400, 12(r1)\n";
#gen2 "cmp r2, r1\n";
#gen1 "cmp \$0x312, r1\n";
#gen1 "cmp \$0x3, r1\n";
#gen2 "imull 0x10(r2), r1\n";
#gen2 "imull r2, r1\n";
#gen1 "imull \$0x1010, r1\n";
#gen1 "imull \$0x1000, r1\n";
#print "movl \$10, -1(%esp)\n";
#gen1 "jmp *-3(r1)\n";
#print "jmp L1+0x8\n";
#print "L1:\n";
#print "jmp .+0x8000\n";
#gen1 "negl r1\n";
#gen1 "notl r1\n";
#gen2 "andl 0x1200(r2), r1\n";
#gen2 "andl r1, r2\n";
#gen1 "andl \$0x10, r1\n";
#gen1 "sarl \$1, r1\n";
#gen1 "sarl %cl, r1\n";
#gen1 "sarl \$9, r1\n";
#gen2 "addl 0x10(r2), r1\n";
#gen2 "addl 0x100(r2), r1\n";
#gen1 "addl \$0x12, 0x10(r1)\n";
#gen1 "addl \$0x12, 0x100(r1)\n";
#gen1 "addl \$0x120, 0x10(r1)\n";
#gen1 "addl \$0x120, 0x100(r1)\n";
#gen2 "addl r1, r2\n";
#gen1 "addl \$0x10, r1\n";
#gen1 "addl \$0x1000, r1\n";

4
src/geninstr/t.s Normal file
View File

@ -0,0 +1,4 @@
.text
addl $10, %esp
addl $-10, %esp

14
src/geninstr/tmp.dump Normal file
View File

@ -0,0 +1,14 @@
tmp.o: file format elf32-i386
Disassembly of section .text:
00000000 <.text>:
0: 0f 94 c0 sete %al
3: 0f 94 c1 sete %cl
6: 0f 94 c2 sete %dl
9: 0f 94 c3 sete %bl
c: 0f 94 c4 sete %ah
f: 0f 94 c5 sete %ch
12: 0f 94 c6 sete %dh
15: 0f 94 c7 sete %bh

9
src/geninstr/tmp.s Normal file
View File

@ -0,0 +1,9 @@
.text
sete %al
sete %cl
sete %dl
sete %bl
sete %ah
sete %ch
sete %dh
sete %bh

39
src/libcafe-4.4.ss Normal file
View File

@ -0,0 +1,39 @@
(let ()
(define eval-depth 0)
(define display-prompt
(lambda (i)
(if (fx= i eval-depth)
(display " " (console-output-port))
(begin
(display ">" (console-output-port))
(display-prompt (fx+ i 1))))))
(define wait
(lambda (eval)
(display-prompt 0)
(let ([x (read (console-input-port))])
(cond
[(eof-object? x)
(newline (console-output-port))]
[else
(let ([v (eval x)])
(unless (eq? v (void))
(write v (console-output-port))
(newline (console-output-port))))
(wait eval)]))))
($pcb-set! new-cafe
(lambda args
(let ([eval
(if (null? args)
(current-eval)
(if (null? (cdr args))
(let ([f (car args)])
(if (procedure? f)
f
(error 'new-cafe "not a procedure ~s" f)))
(error 'new-cafe "too many arguments")))])
(set! eval-depth (fxadd1 eval-depth))
(wait eval)
(set! eval-depth (fxsub1 eval-depth))))))

66
src/libcafe-5.3.ss Normal file
View File

@ -0,0 +1,66 @@
(let ()
(define with-error-handler
(lambda (p thunk)
(let ([old-error-handler (current-error-handler)])
(dynamic-wind
(lambda ()
(current-error-handler
(lambda args
(current-error-handler old-error-handler)
(apply p args)
(apply error args))))
thunk
(lambda ()
(current-error-handler old-error-handler))))))
(define eval-depth 0)
(define display-prompt
(lambda (i)
(if (fx= i eval-depth)
(display " " (console-output-port))
(begin
(display ">" (console-output-port))
(display-prompt (fx+ i 1))))))
(define wait
(lambda (eval escape-k)
(call/cc
(lambda (k)
(with-error-handler
(lambda args
(apply print-error args)
(k (void)))
(lambda ()
(display-prompt 0)
(let ([x (read (console-input-port))])
(cond
[(eof-object? x)
(newline (console-output-port))
(escape-k (void))]
[else
(let ([v (eval x)])
(unless (eq? v (void))
(write v (console-output-port))
(newline (console-output-port))))]))))))
(wait eval escape-k)))
($pcb-set! new-cafe
(lambda args
(let ([eval
(if (null? args)
(current-eval)
(if (null? (cdr args))
(let ([f (car args)])
(if (procedure? f)
f
(error 'new-cafe "not a procedure ~s" f)))
(error 'new-cafe "too many arguments")))])
(dynamic-wind
(lambda () (set! eval-depth (fxadd1 eval-depth)))
(lambda ()
(call/cc
(lambda (k)
(wait eval k))))
(lambda () (set! eval-depth (fxsub1 eval-depth))))))))

67
src/libcafe-5.6.ss Normal file
View File

@ -0,0 +1,67 @@
(let ()
(define with-error-handler
(lambda (p thunk)
(let ([old-error-handler (current-error-handler)])
(dynamic-wind
(lambda ()
(current-error-handler
(lambda args
(current-error-handler old-error-handler)
(apply p args)
(apply error args))))
thunk
(lambda ()
(current-error-handler old-error-handler))))))
(define eval-depth 0)
(define display-prompt
(lambda (i)
(if (fx= i eval-depth)
(display " " (console-output-port))
(begin
(display ">" (console-output-port))
(display-prompt (fx+ i 1))))))
(define wait
(lambda (eval escape-k)
(call/cc
(lambda (k)
(with-error-handler
(lambda args
(reset-input-port! (console-input-port))
(apply print-error args)
(k (void)))
(lambda ()
(display-prompt 0)
(let ([x (read (console-input-port))])
(cond
[(eof-object? x)
(newline (console-output-port))
(escape-k (void))]
[else
(let ([v (eval x)])
(unless (eq? v (void))
(write v (console-output-port))
(newline (console-output-port))))]))))))
(wait eval escape-k)))
($pcb-set! new-cafe
(lambda args
(let ([eval
(if (null? args)
(current-eval)
(if (null? (cdr args))
(let ([f (car args)])
(if (procedure? f)
f
(error 'new-cafe "not a procedure ~s" f)))
(error 'new-cafe "too many arguments")))])
(dynamic-wind
(lambda () (set! eval-depth (fxadd1 eval-depth)))
(lambda ()
(call/cc
(lambda (k)
(wait eval k))))
(lambda () (set! eval-depth (fxsub1 eval-depth))))))))

72
src/libcafe-5.8.ss Normal file
View File

@ -0,0 +1,72 @@
(let ()
(define with-error-handler
(lambda (p thunk)
(let ([old-error-handler (current-error-handler)])
(dynamic-wind
(lambda ()
(current-error-handler
(lambda args
(current-error-handler old-error-handler)
(apply p args)
(apply error args))))
thunk
(lambda ()
(current-error-handler old-error-handler))))))
(define eval-depth 0)
(define display-prompt
(lambda (i)
(if (fx= i eval-depth)
(display " " (console-output-port))
(begin
(display ">" (console-output-port))
(display-prompt (fx+ i 1))))))
(define wait
(lambda (eval escape-k)
(call/cc
(lambda (k)
(with-error-handler
(lambda args
(reset-input-port! (console-input-port))
(apply print-error args)
(k (void)))
(lambda ()
(display-prompt 0)
(let ([x (read (console-input-port))])
(cond
[(eof-object? x)
(newline (console-output-port))
(escape-k (void))]
[else
(call-with-values
(lambda () (eval x))
(lambda v*
(unless (andmap (lambda (v) (eq? v (void))) v*)
(for-each
(lambda (v)
(write v (console-output-port))
(newline (console-output-port)))
v*))))]))))))
(wait eval escape-k)))
($pcb-set! new-cafe
(lambda args
(let ([eval
(if (null? args)
(current-eval)
(if (null? (cdr args))
(let ([f (car args)])
(if (procedure? f)
f
(error 'new-cafe "not a procedure ~s" f)))
(error 'new-cafe "too many arguments")))])
(dynamic-wind
(lambda () (set! eval-depth (fxadd1 eval-depth)))
(lambda ()
(call/cc
(lambda (k)
(wait eval k))))
(lambda () (set! eval-depth (fxsub1 eval-depth))))))))

19
src/libcollect-5.2.ss Normal file
View File

@ -0,0 +1,19 @@
;($pcb-set! do-overflow
; (lambda ()
; ($do-overflow 4096)))
($pcb-set! do-overflow
(lambda ()
(foreign-call "S_collect" 4096)
(void)))
($pcb-set! collect
(lambda ()
(do-overflow)))
($pcb-set! do-overflow-with-byte-count
(lambda (n)
(foreign-call "S_collect" n)
(void)))

23
src/libcollect-5.3.ss Normal file
View File

@ -0,0 +1,23 @@
;($pcb-set! do-overflow
; (lambda ()
; ($do-overflow 4096)))
($pcb-set! do-overflow
(lambda ()
(foreign-call "S_collect" 4096)
(void)))
($pcb-set! collect
(lambda ()
(do-overflow)))
($pcb-set! do-overflow-with-byte-count
(lambda (n)
(foreign-call "S_collect" n)
(void)))
($pcb-set! do-stack-overflow
(lambda ()
(foreign-call "S_stack_overflow")))

23
src/libcompile-5.9.ss Normal file
View File

@ -0,0 +1,23 @@
;;; libcompile should provide: compile-core->asm
;;; it takes one expression in core scheme, and produces a list of
;;; assembly codes (each is a list of instructions).
;;; the resulting lists can then either be fed to the gas backend to
;;; produce assembly files, or to the online assembler to produce
;;; code.
;;;
;;; complications:
;;; * The gas backend does not support 3D objects. The online
;;; assembler does. We provide a parameter, assembler-backend,
;;; that when set to 'online, suppresses removing complex constants
;;; and when set to 'offline, suppresses proucing 3D objects.
;;;
($pcb-set! assembler-backend
(make-parameter
'online
(lambda (x)
(unless (memq x '(online offline))
(error 'assembler-backend "invalid backend ~s" x))
x)))

86
src/libcontrol-5.3.ss Normal file
View File

@ -0,0 +1,86 @@
(let ([winders '()])
(define call-with-current-frame
(lambda (f)
(if ($fp-at-base)
(f ($current-frame))
($seal-frame-and-call f))))
(define primitive-call/cc
(lambda (f)
(call-with-current-frame
(lambda (frm)
(f (lambda (value)
($set-current-frame! frm)
($underflow-and-return value)))))))
(define len
(lambda (ls n)
(if (null? ls)
n
(len (cdr ls) (fxadd1 n)))))
(define list-tail
(lambda (ls n)
(if (fxzero? n)
ls
(list-tail (cdr ls) (fxsub1 n)))))
(define drop-uncommon-heads
(lambda (x y)
(if (eq? x y)
x
(drop-uncommon-heads (cdr x) (cdr y)))))
(define common-tail
(lambda (x y)
(let ([lx (len x 0)] [ly (len y 0)])
(let ([x (if (fx> lx ly) (list-tail x (fx- lx ly)) x)]
[y (if (fx> ly lx) (list-tail y (fx- ly lx)) y)])
(if (eq? x y)
x
(drop-uncommon-heads (cdr x) (cdr y)))))))
(define unwind*
(lambda (ls tail)
(unless (eq? ls tail)
(set! winders (cdr ls))
((cdar ls))
(unwind* (cdr ls) tail))))
(define rewind*
(lambda (ls tail)
(unless (eq? ls tail)
(rewind* (cdr ls) tail)
((caar ls))
(set! winders ls))))
(define do-wind
(lambda (new)
(let ([tail (common-tail new winders)])
(unwind* winders tail)
(rewind* new tail))))
(define call/cc
(lambda (f)
(primitive-call/cc
(lambda (k)
(let ([save winders])
(f (lambda v*
(unless (eq? save winders) (do-wind save))
($apply k v*))))))))
(define dynamic-wind
(lambda (in body out)
(in)
(set! winders (cons (cons in out) winders))
(let ([v (body)])
(set! winders (cdr winders))
(out)
v)))
($pcb-set! call/cf call-with-current-frame)
($pcb-set! call/cc call/cc)
($pcb-set! dynamic-wind dynamic-wind))

84
src/libcontrol-5.5.ss Normal file
View File

@ -0,0 +1,84 @@
(let ([winders '()])
(define call-with-current-frame
(lambda (f)
(if ($fp-at-base)
(f ($current-frame))
($seal-frame-and-call f))))
(define primitive-call/cc
(lambda (f)
(call-with-current-frame
(lambda (frm)
(f ($frame->continuation frm))))))
(define len
(lambda (ls n)
(if (null? ls)
n
(len (cdr ls) (fxadd1 n)))))
(define list-tail
(lambda (ls n)
(if (fxzero? n)
ls
(list-tail (cdr ls) (fxsub1 n)))))
(define drop-uncommon-heads
(lambda (x y)
(if (eq? x y)
x
(drop-uncommon-heads (cdr x) (cdr y)))))
(define common-tail
(lambda (x y)
(let ([lx (len x 0)] [ly (len y 0)])
(let ([x (if (fx> lx ly) (list-tail x (fx- lx ly)) x)]
[y (if (fx> ly lx) (list-tail y (fx- ly lx)) y)])
(if (eq? x y)
x
(drop-uncommon-heads (cdr x) (cdr y)))))))
(define unwind*
(lambda (ls tail)
(unless (eq? ls tail)
(set! winders (cdr ls))
((cdar ls))
(unwind* (cdr ls) tail))))
(define rewind*
(lambda (ls tail)
(unless (eq? ls tail)
(rewind* (cdr ls) tail)
((caar ls))
(set! winders ls))))
(define do-wind
(lambda (new)
(let ([tail (common-tail new winders)])
(unwind* winders tail)
(rewind* new tail))))
(define call/cc
(lambda (f)
(primitive-call/cc
(lambda (k)
(let ([save winders])
(f (lambda v*
(unless (eq? save winders) (do-wind save))
(apply k v*))))))))
(define dynamic-wind
(lambda (in body out)
(in)
(set! winders (cons (cons in out) winders))
(let ([v (body)])
(set! winders (cdr winders))
(out)
v)))
($pcb-set! call/cf call-with-current-frame)
($pcb-set! call/cc call/cc)
($pcb-set! dynamic-wind dynamic-wind))

95
src/libcontrol-5.8.ss Normal file
View File

@ -0,0 +1,95 @@
(let ([winders '()])
(define call-with-current-frame
(lambda (f)
(if ($fp-at-base)
(f ($current-frame))
($seal-frame-and-call f))))
(define primitive-call/cc
(lambda (f)
(call-with-current-frame
(lambda (frm)
(f ($frame->continuation frm))))))
(define len
(lambda (ls n)
(if (null? ls)
n
(len (cdr ls) (fxadd1 n)))))
(define list-tail
(lambda (ls n)
(if (fxzero? n)
ls
(list-tail (cdr ls) (fxsub1 n)))))
(define drop-uncommon-heads
(lambda (x y)
(if (eq? x y)
x
(drop-uncommon-heads (cdr x) (cdr y)))))
(define common-tail
(lambda (x y)
(let ([lx (len x 0)] [ly (len y 0)])
(let ([x (if (fx> lx ly) (list-tail x (fx- lx ly)) x)]
[y (if (fx> ly lx) (list-tail y (fx- ly lx)) y)])
(if (eq? x y)
x
(drop-uncommon-heads (cdr x) (cdr y)))))))
(define unwind*
(lambda (ls tail)
(unless (eq? ls tail)
(set! winders (cdr ls))
((cdar ls))
(unwind* (cdr ls) tail))))
(define rewind*
(lambda (ls tail)
(unless (eq? ls tail)
(rewind* (cdr ls) tail)
((caar ls))
(set! winders ls))))
(define do-wind
(lambda (new)
(let ([tail (common-tail new winders)])
(unwind* winders tail)
(rewind* new tail))))
(define call/cc
(lambda (f)
(primitive-call/cc
(lambda (k)
(let ([save winders])
(f (lambda v*
(unless (eq? save winders) (do-wind save))
(apply k v*))))))))
;;; (define dynamic-wind
;;; (lambda (in body out)
;;; (in)
;;; (set! winders (cons (cons in out) winders))
;;; (let ([v (body)])
;;; (set! winders (cdr winders))
;;; (out)
;;; v)))
(define dynamic-wind
(lambda (in body out)
(in)
(set! winders (cons (cons in out) winders))
(call-with-values
body
(lambda v*
(set! winders (cdr winders))
(out)
(apply values v*)))))
($pcb-set! call/cf call-with-current-frame)
($pcb-set! call/cc call/cc)
($pcb-set! dynamic-wind dynamic-wind))

901
src/libcore-4.4.ss Normal file
View File

@ -0,0 +1,901 @@
($pcb-set! error
(lambda args
(foreign-call "S_error" args)))
($pcb-set! exit
(lambda args
(if (null? args)
($exit 0)
(if (null? ($cdr args))
($exit ($car args))
(error 'exit "too many arguments")))))
($pcb-set! eof-object
(lambda () (eof-object)))
($pcb-set! void
(lambda () (void)))
($pcb-set! eof-object?
(lambda (x) (eof-object? x)))
($pcb-set! fxadd1
(lambda (n)
(unless (fixnum? n)
(error 'fxadd1 "~s is not a fixnum" n))
($fxadd1 n)))
($pcb-set! fxsub1
(lambda (n)
(unless (fixnum? n)
(error 'fxsub1 "~s is not a fixnum" n))
($fxsub1 n)))
($pcb-set! fixnum->char
(lambda (n)
(unless (fixnum? n)
(error 'fixnum->char "~s is not a fixnum" n))
(unless (and ($fx>= n 0)
($fx<= n 127))
(error 'fixnum->char "~s is out of range[0..127]" n))
($fixnum->char n)))
($pcb-set! char->fixnum
(lambda (x)
(unless (char? x)
(error 'char->fixnum "~s is not a character" x))
($char->fixnum x)))
($pcb-set! fxlognot
(lambda (x)
(unless (fixnum? x)
(error 'fxlognot "~s is not a fixnum" x))
($fxlognot x)))
($pcb-set! fixnum? (lambda (x) (fixnum? x)))
($pcb-set! fxzero?
(lambda (x)
(unless (fixnum? x)
(error 'fxzero? "~s is not a fixnum" x))
($fxzero? x)))
($pcb-set! boolean? (lambda (x) (boolean? x)))
($pcb-set! char? (lambda (x) (char? x)))
($pcb-set! vector? (lambda (x) (vector? x)))
($pcb-set! string? (lambda (x) (string? x)))
($pcb-set! procedure? (lambda (x) (procedure? x)))
($pcb-set! null? (lambda (x) (null? x)))
($pcb-set! pair? (lambda (x) (pair? x)))
($pcb-set! car
(lambda (x)
(unless (pair? x)
(error 'car "~s is not a pair" x))
($car x)))
($pcb-set! cdr
(lambda (x)
(unless (pair? x)
(error 'cdr "~s is not a pair" x))
($cdr x)))
($pcb-set! caar
(lambda (x)
(unless (pair? x) (error 'caar "incorrect list structure ~s" x))
(let ([a ($car x)])
(unless (pair? a) (error 'caar "incorrect list structure ~s" x))
($car a))))
($pcb-set! cadr
(lambda (x)
(unless (pair? x) (error 'cadr "incorrect list structure ~s" x))
(let ([d ($cdr x)])
(unless (pair? d) (error 'cadr "incorrect list structure ~s" x))
($car d))))
($pcb-set! cdar
(lambda (x)
(unless (pair? x) (error 'cdar "incorrect list structure ~s" x))
(let ([a ($car x)])
(unless (pair? a) (error 'cdar "incorrect list structure ~s" x))
($cdr a))))
($pcb-set! cddr
(lambda (x)
(unless (pair? x) (error 'cddr "incorrect list structure ~s" x))
(let ([d ($cdr x)])
(unless (pair? d) (error 'cddr "incorrect list structure ~s" x))
($cdr d))))
($pcb-set! caddr
(lambda (x)
(unless (pair? x) (error 'caddr "incorrect list structure ~s" x))
(let ([d ($cdr x)])
(unless (pair? d) (error 'caddr "incorrect list structure ~s" x))
(let ([dd ($cdr d)])
(unless (pair? dd) (error 'caddr "correct list structure ~s" x))
($car dd)))))
($pcb-set! cadddr
(lambda (x)
(unless (pair? x) (error 'cadddr "incorrect list structure ~s" x))
(let ([d ($cdr x)])
(unless (pair? d) (error 'cadddr "incorrect list structure ~s" x))
(let ([dd ($cdr d)])
(unless (pair? dd) (error 'cadddr "correct list structure ~s" x))
(let ([ddd ($cdr dd)])
(unless (pair? ddd) (error 'cadddr "correct list structure ~s" x))
($car ddd))))))
($pcb-set! cddddr
(lambda (x)
(unless (pair? x) (error 'cddddr "incorrect list structure ~s" x))
(let ([d ($cdr x)])
(unless (pair? d) (error 'cddddr "incorrect list structure ~s" x))
(let ([dd ($cdr d)])
(unless (pair? dd) (error 'cddddr "correct list structure ~s" x))
(let ([ddd ($cdr dd)])
(unless (pair? ddd) (error 'cddddr "correct list structure ~s" x))
($cdr ddd))))))
(let ()
(define fill!
(lambda (v i n fill)
(cond
[($fx= i n) v]
[else
($vector-set! v i fill)
(fill! v ($fx+ i 1) n fill)])))
($pcb-set! make-vector
(lambda (n . opt)
(unless (and (fixnum? n) ($fx>= n 0))
(error 'make-vector "~s is not a valid size" n))
(let ([fill (if (null? opt)
#f
(if (null? ($cdr opt))
($car opt)
(error 'make-vector "too many arguments")))])
(let ([v ($make-vector n)])
(fill! v 0 n fill))))))
($pcb-set! vector-length
(lambda (x)
(unless (vector? x)
(error 'vector-length "~s is not a vector" x))
($vector-length x)))
($pcb-set! make-string
(lambda (x)
(unless (and (fixnum? x) ($fx>= x 0))
(error 'make-string "~s is not a valid size" x))
($make-string x)))
($pcb-set! string-length
(lambda (x)
(unless (string? x)
(error 'string-length "~s is not a string" x))
($string-length x)))
($pcb-set! not (lambda (x) (not x)))
($pcb-set! symbol->string
(lambda (x)
(unless (symbol? x)
(error 'symbol->string "~s is not a symbol" x))
($symbol-string x)))
($pcb-set! top-level-value
(lambda (x)
(unless (symbol? x)
(error 'top-level-value "~s is not a symbol" x))
(let ([v ($symbol-value x)])
(when ($unbound-object? v)
(error 'top-level-value "unbound variable ~s" x))
v)))
($pcb-set! top-level-bound?
(lambda (x)
(unless (symbol? x)
(error 'top-level-bound? "~s is not a symbol" x))
(not ($unbound-object? ($symbol-value x)))))
($pcb-set! set-top-level-value!
(lambda (x v)
(unless (symbol? x)
(error 'set-top-level-value! "~s is not a symbol" x))
($set-symbol-value! x v)))
($pcb-set! symbol? (lambda (x) (symbol? x)))
($pcb-set! fx+
(lambda (x y)
(unless (fixnum? x)
(error 'fx+ "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fx+ "~s is not a fixnum" y))
($fx+ x y)))
($pcb-set! fx-
(lambda (x y)
(unless (fixnum? x)
(error 'fx- "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fx- "~s is not a fixnum" y))
($fx- x y)))
($pcb-set! fx*
(lambda (x y)
(unless (fixnum? x)
(error 'fx* "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fx* "~s is not a fixnum" y))
($fx* x y)))
($pcb-set! fxquotient
(lambda (x y)
(unless (fixnum? x)
(error 'fxquotient "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fxquotient "~s is not a fixnum" y))
(when ($fxzero? y)
(error 'fxquotient "zero dividend ~s" y))
($fxquotient x y)))
($pcb-set! fxremainder
(lambda (x y)
(unless (fixnum? x)
(error 'fxremainder "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fxremainder "~s is not a fixnum" y))
(when ($fxzero? y)
(error 'fxremainder "zero dividend ~s" y))
(let ([q ($fxquotient x y)])
($fx- x ($fx* q y)))))
($pcb-set! fxlogor
(lambda (x y)
(unless (fixnum? x)
(error 'fxlogor "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fxlogor "~s is not a fixnum" y))
($fxlogor x y)))
($pcb-set! fxlogxor
(lambda (x y)
(unless (fixnum? x)
(error 'fxlogxor "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fxlogxor "~s is not a fixnum" y))
($fxlogxor x y)))
($pcb-set! fxlogand
(lambda (x y)
(unless (fixnum? x)
(error 'fxlogand "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fxlogand "~s is not a fixnum" y))
($fxlogand x y)))
($pcb-set! fxsra
(lambda (x y)
(unless (fixnum? x)
(error 'fxsra "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fxsra "~s is not a fixnum" y))
(unless ($fx>= y 0)
(error 'fxsra "negative shift not allowed, got ~s" y))
($fxsra x y)))
($pcb-set! fxsll
(lambda (x y)
(unless (fixnum? x)
(error 'fxsll "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fxsll "~s is not a fixnum" y))
(unless ($fx>= y 0)
(error 'fxsll "negative shift not allowed, got ~s" y))
($fxsll x y)))
($pcb-set! fx=
(lambda (x y)
(unless (fixnum? x)
(error 'fx= "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fx= "~s is not a fixnum" y))
($fx= x y)))
($pcb-set! fx<
(lambda (x y)
(unless (fixnum? x)
(error 'fx< "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fx< "~s is not a fixnum" y))
($fx< x y)))
($pcb-set! fx<=
(lambda (x y)
(unless (fixnum? x)
(error 'fx<= "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fx<= "~s is not a fixnum" y))
($fx<= x y)))
($pcb-set! fx>
(lambda (x y)
(unless (fixnum? x)
(error 'fx> "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fx> "~s is not a fixnum" y))
($fx> x y)))
($pcb-set! fx>=
(lambda (x y)
(unless (fixnum? x)
(error 'fx>= "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fx>= "~s is not a fixnum" y))
($fx>= x y)))
($pcb-set! char=
(lambda (x y)
(unless (char? x)
(error 'char= "~s is not a character" x))
(unless (char? y)
(error 'char= "~s is not a character" y))
($char= x y)))
($pcb-set! char<
(lambda (x y)
(unless (char? x)
(error 'char< "~s is not a character" x))
(unless (char? y)
(error 'char< "~s is not a character" y))
($char< x y)))
($pcb-set! char<=
(lambda (x y)
(unless (char? x)
(error 'char<= "~s is not a character" x))
(unless (char? y)
(error 'char<= "~s is not a character" y))
($char<= x y)))
($pcb-set! char>
(lambda (x y)
(unless (char? x)
(error 'char> "~s is not a character" x))
(unless (char? y)
(error 'char> "~s is not a character" y))
($char> x y)))
($pcb-set! char>=
(lambda (x y)
(unless (char? x)
(error 'char>= "~s is not a character" x))
(unless (char? y)
(error 'char>= "~s is not a character" y))
($char>= x y)))
($pcb-set! cons (lambda (x y) (cons x y)))
($pcb-set! eq? (lambda (x y) (eq? x y)))
($pcb-set! set-car!
(lambda (x y)
(unless (pair? x)
(error 'set-car! "~s is not a pair" x))
($set-car! x y)))
($pcb-set! set-cdr!
(lambda (x y)
(unless (pair? x)
(error 'set-cdr! "~s is not a pair" x))
($set-cdr! x y)))
($pcb-set! vector-ref
(lambda (v i)
(unless (vector? v)
(error 'vector-ref "~s is not a vector" v))
(unless (fixnum? i)
(error 'vector-ref "~s is not a valid index" i))
(unless (and ($fx< i ($vector-length v))
($fx<= 0 i))
(error 'vector-ref "index ~s is out of range for ~s" i v))
($vector-ref v i)))
($pcb-set! string-ref
(lambda (s i)
(unless (string? s)
(error 'string-ref "~s is not a string" s))
(unless (fixnum? i)
(error 'string-ref "~s is not a valid index" i))
(unless (and ($fx< i ($string-length s))
($fx<= 0 i))
(error 'string-ref "index ~s is out of range for ~s" i s))
($string-ref s i)))
($pcb-set! vector-set!
(lambda (v i c)
(unless (vector? v)
(error 'vector-set! "~s is not a vector" v))
(unless (fixnum? i)
(error 'vector-set! "~s is not a valid index" i))
(unless (and ($fx< i ($vector-length v))
($fx<= 0 i))
(error 'vector-set! "index ~s is out of range for ~s" i v))
($vector-set! v i c)))
($pcb-set! string-set!
(lambda (s i c)
(unless (string? s)
(error 'string-set! "~s is not a string" s))
(unless (fixnum? i)
(error 'string-set! "~s is not a valid index" i))
(unless (and ($fx< i ($string-length s))
($fx>= i 0))
(error 'string-set! "index ~s is out of range for ~s" i s))
(unless (char? c)
(error 'string-set! "~s is not a character" c))
($string-set! s i c)))
($pcb-set! vector
(letrec ([length
(lambda (ls n)
(cond
[(null? ls) n]
[else (length ($cdr ls) ($fx+ n 1))]))]
[loop
(lambda (v ls i n)
(cond
[($fx= i n) v]
[else
($vector-set! v i ($car ls))
(loop v ($cdr ls) ($fx+ i 1) n)]))])
(lambda ls
(let ([n (length ls 0)])
(let ([v ($make-vector n)])
(loop v ls 0 n))))))
(letrec ([length
(lambda (ls n)
(cond
[(null? ls) n]
[else (length ($cdr ls) ($fx+ n 1))]))]
[loop
(lambda (s ls i n)
(cond
[($fx= i n) s]
[else
(let ([c ($car ls)])
(unless (char? c)
(error 'string "~s is not a character" c))
($string-set! s i c)
(loop s ($cdr ls) ($fx+ i 1) n))]))])
(let ([f
(lambda ls
(let ([n (length ls 0)])
(let ([s ($make-string n)])
(loop s ls 0 n))))])
($pcb-set! string f)))
($pcb-set! list?
(letrec ([race
(lambda (h t)
(if (pair? h)
(let ([h ($cdr h)])
(if (pair? h)
(and (not (eq? h t))
(race ($cdr h) ($cdr t)))
(null? h)))
(null? h)))])
(lambda (x) (race x x))))
($pcb-set! reverse
(letrec ([race
(lambda (h t ls ac)
(if (pair? h)
(let ([h ($cdr h)] [ac (cons ($car h) ac)])
(if (pair? h)
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls (cons ($car h) ac))
(error 'reverse "~s is a circular list" ls))
(if (null? h)
ac
(error 'reverse "~s is not a proper list" ls))))
(if (null? h)
ac
(error 'reverse "~s is not a proper list" ls))))])
(lambda (x)
(race x x x '()))))
($pcb-set! memq
(letrec ([race
(lambda (h t ls x)
(if (pair? h)
(if (eq? ($car h) x)
h
(let ([h ($cdr h)])
(if (pair? h)
(if (eq? ($car h) x)
h
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls x)
(error 'memq "circular list ~s" ls)))
(if (null? h)
'#f
(error 'memq "~s is not a proper list" ls)))))
(if (null? h)
'#f
(error 'memq "~s is not a proper list" ls))))])
(lambda (x ls)
(race ls ls ls x))))
($pcb-set! list->string
(letrec ([race
(lambda (h t ls n)
(if (pair? h)
(let ([h ($cdr h)])
(if (pair? h)
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls ($fx+ n 2))
(error 'reverse "circular list ~s" ls))
(if (null? h)
($fx+ n 1)
(error 'reverse "~s is not a proper list" ls))))
(if (null? h)
n
(error 'reverse "~s is not a proper list" ls))))]
[fill
(lambda (s i ls)
(cond
[(null? ls) s]
[else
(let ([c ($car ls)])
(unless (char? c)
(error 'list->string "~s is not a character" c))
($string-set! s i c)
(fill s ($fxadd1 i) (cdr ls)))]))])
(lambda (ls)
(let ([n (race ls ls ls 0)])
(let ([s ($make-string n)])
(fill s 0 ls))))))
($pcb-set! length
(letrec ([race
(lambda (h t ls n)
(if (pair? h)
(let ([h ($cdr h)])
(if (pair? h)
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls ($fx+ n 2))
(error 'length "circular list ~s" ls))
(if (null? h)
($fx+ n 1)
(error 'length "~s is not a proper list" ls))))
(if (null? h)
n
(error 'length "~s is not a proper list" ls))))])
(lambda (ls)
(race ls ls ls 0))))
($pcb-set! apply
(letrec ([fix
(lambda (arg arg*)
(cond
[(null? arg*)
(if (list? arg)
arg
(error 'apply "~s is not a list" arg))]
[else
(cons arg (fix ($car arg*) ($cdr arg*)))]))])
(lambda (f arg . arg*)
($apply f (fix arg arg*)))))
($pcb-set! assq
(letrec ([race
(lambda (x h t ls)
(if (pair? h)
(let ([a ($car h)] [h ($cdr h)])
(if (pair? a)
(if (eq? ($car a) x)
a
(if (pair? h)
(if (not (eq? h t))
(let ([a ($car h)])
(if (pair? a)
(if (eq? ($car a) x)
a
(race x ($cdr h) ($cdr t) ls))
(error 'assq "malformed alist ~s"
ls)))
(error 'assq "circular list ~s" ls))
(if (null? h)
#f
(error 'assq "~s is not a proper list" ls))))
(error 'assq "malformed alist ~s" ls)))
(if (null? h)
#f
(error 'assq "~s is not a proper list" ls))))])
(lambda (x ls)
(race x ls ls ls))))
($pcb-set! string->symbol
(lambda (x)
(unless (string? x)
(error 'string->symbol "~s is not a string" x))
($intern x)))
($pcb-set! gensym
(lambda args
(if (null? args)
($make-symbol "g")
(if (null? ($cdr args))
(let ([a ($car args)])
(if (string? a)
($make-symbol a)
(error 'gensym "~s is not a string" a)))
(error 'gensym "too many arguments")))))
($pcb-set! make-parameter
(letrec ([make-param-no-guard
(lambda (x)
(lambda args
(if (null? args)
x
(if (null? ($cdr args))
(set! x ($car args))
(error #f "too many arguments to parameter")))))]
[make-param-with-guard
(lambda (x g)
(let ([f
(lambda args
(if (null? args)
x
(if (null? ($cdr args))
(set! x (g ($car args)))
(error #f "too many arguments to parameter"))))])
(if (procedure? g)
(begin (set! x (g x)) f)
(error 'make-parameter "not a procedure ~s" g))))])
(lambda args
(if (pair? args)
(let ([x ($car args)] [args ($cdr args)])
(if (null? args)
(make-param-no-guard x)
(let ([g ($car args)])
(if (null? ($cdr args))
(make-param-with-guard x g)
(error 'make-parameter "too many arguments")))))
(error 'make-parameter "insufficient arguments")))))
(let ()
(define vector-loop
(lambda (x y i n)
(or ($fx= i n)
(and (equal? ($vector-ref x i) ($vector-ref y i))
(vector-loop x y ($fxadd1 i) n)))))
(define string-loop
(lambda (x y i n)
(or ($fx= i n)
(and ($char= ($string-ref x i) ($string-ref y i))
(string-loop x y ($fxadd1 i) n)))))
(define equal?
(lambda (x y)
(cond
[(eq? x y) #t]
[(pair? x)
(and (pair? y)
(equal? ($car x) ($car y))
(equal? ($cdr x) ($cdr y)))]
[(vector? x)
(and (vector? y)
(let ([n ($vector-length x)])
(and ($fx= n ($vector-length y))
(vector-loop x y 0 n))))]
[(string? x)
(and (string? y)
(let ([n ($string-length x)])
(and ($fx= n ($string-length y))
(string-loop x y 0 n))))]
[else #f])))
($pcb-set! equal? equal?))
(let ()
(define map1
(lambda (h t ls f)
(if (pair? h)
(let ([h ($cdr h)] [a1 ($car h)])
(if (pair? h)
(if (not (eq? h t))
(let ([a2 ($car h)])
(cons (f a1) (cons (f a2) (map1 ($cdr h) ($cdr t) ls f))))
(error 'map "circular list ~s" ls))
(if (null? h)
(cons (f a1) '())
(error 'map "~s is not a proper list" ls))))
(if (null? h)
'()
(error 'map "~s is not a proper list" ls)))))
($pcb-set! map
(lambda (f ls . ls*)
(unless (procedure? f)
(error 'map "not a procedure ~s" f))
(if (null? ls*)
(map1 ls ls ls f)
(error 'map "multiarg not supported yet")))))
(let ()
(define for-each1
(lambda (h t ls f)
(if (pair? h)
(let ([h ($cdr h)] [a1 ($car h)])
(if (pair? h)
(if (not (eq? h t))
(let ([a2 ($car h)])
(f a1)
(f a2)
(for-each1 ($cdr h) ($cdr t) ls f))
(error 'for-each "circular list ~s" ls))
(if (null? h)
(begin (f a1) (void))
(error 'for-each "~s is not a proper list" ls))))
(if (null? h)
(void)
(error 'for-each "~s is not a proper list" ls)))))
($pcb-set! for-each
(lambda (f ls . ls*)
(unless (procedure? f)
(error 'for-each "not a procedure ~s" f))
(if (null? ls*)
(for-each1 ls ls ls f)
(error 'for-each "multiarg not supported yet")))))
(let ()
(define andmap1
(lambda (a h t ls f)
(if (pair? h)
(let ([h ($cdr h)] [a1 ($car h)])
(if (pair? h)
(if (not (eq? h t))
(let ([a2 ($car h)])
(and (f a)
(f a1)
(andmap1 a2 ($cdr h) ($cdr t) ls f)))
(error 'andmap "circular list ~s" ls))
(if (null? h)
(and (f a) (f a1))
(error 'andmap "~s is not a proper list" ls))))
(if (null? h)
(f a)
(error 'map "~s is not a proper list" ls)))))
($pcb-set! andmap
(lambda (f ls . ls*)
(unless (procedure? f)
(error 'andmap "not a procedure ~s" f))
(if (null? ls*)
(if (null? ls)
#t
(andmap1 (car ls) (cdr ls) (cdr ls) ls f))
(error 'andmap "multiarg not supported yet")))))
(let ()
(define reverse
(lambda (h t ls ac)
(if (pair? h)
(let ([h ($cdr h)] [a1 ($car h)])
(if (pair? h)
(if (not (eq? h t))
(let ([a2 ($car h)])
(reverse ($cdr h) ($cdr t) ls (cons a2 (cons a1 ac))))
(error 'append "circular list ~s" ls))
(if (null? h)
(cons a1 '())
(error 'append "~s is not a proper list" ls))))
(if (null? h)
ac
(error 'append "~s is not a proper list" ls)))))
(define revcons
(lambda (ls ac)
(cond
[(pair? ls)
(revcons ($cdr ls) (cons ($car ls) ac))]
[else ac])))
(define append
(lambda (ls ls*)
(cond
[(null? ls*) ls]
[else
(revcons (reverse ls ls ls '())
(append ($car ls*) ($cdr ls*)))])))
($pcb-set! append
(lambda (ls . ls*)
(append ls ls*))))
($pcb-set! list->vector
(letrec ([race
(lambda (h t ls n)
(if (pair? h)
(let ([h ($cdr h)])
(if (pair? h)
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls ($fx+ n 2))
(error 'list->vector "circular list ~s" ls))
(if (null? h)
($fx+ n 1)
(error 'list->vector "~s is not a proper list" ls))))
(if (null? h)
n
(error 'list->vector "~s is not a proper list" ls))))]
[fill
(lambda (v i ls)
(cond
[(null? ls) v]
[else
(let ([c ($car ls)])
($vector-set! v i c)
(fill v ($fxadd1 i) (cdr ls)))]))])
(lambda (ls)
(let ([n (race ls ls ls 0)])
(let ([v ($make-vector n)])
(fill v 0 ls))))))
(let ()
(define f
(lambda (v i ls)
(cond
[($fx< i 0) ls]
[else
(f v ($fxsub1 i) (cons ($vector-ref v i) ls))])))
($pcb-set! vector->list
(lambda (v)
(if (vector? v)
(let ([n ($vector-length v)])
(if ($fxzero? n)
'()
(f v ($fxsub1 n) '())))
(error 'vector->list "~s is not a vector" v)))))
(let ()
(define f
(lambda (n fill ls)
(cond
[($fxzero? n) ls]
[else
(f ($fxsub1 n) fill (cons fill ls))])))
($pcb-set! make-list
(lambda (n . args)
(let ([fill
(if (null? args)
(void)
(if (null? (cdr args))
(car args)
(error 'make-list "too many arguments")))])
(if (fixnum? n)
(if ($fx>= n 0)
(f n fill '())
(error 'make-list "negative size ~s" n))
(error 'make-list "invalid size ~s" n))))))
($pcb-set! list (lambda x x))

1306
src/libcore-5.6.ss Normal file
View File

File diff suppressed because it is too large Load Diff

1282
src/libcore-5.7.ss Normal file
View File

File diff suppressed because it is too large Load Diff

564
src/libeval-4.4.ss Normal file
View File

@ -0,0 +1,564 @@
(let ()
(define verify-proper-lambda-bindings
(lambda (fml*)
(void)))
(define keyword?
(lambda (x)
(memq x
'(lambda let let* letrec letrec* if quote when unless
set! begin define or and cond))))
(define self-evaluating?
(lambda (x)
(or (fixnum? x) (null? x) (boolean? x) (char? x) (string? x))))
(define extend-r
(lambda (fml* r)
(cons fml* r)))
(define classify
(lambda (fml* k)
(let f ([fml* fml*] [i 0])
(cond
[(null? fml*) (k i #t)]
[(pair? fml*) (f (cdr fml*) (fx+ i 1))]
[else (k i #f)]))))
(define compile-lambda-binder
(lambda (fml*)
(classify fml*
(lambda (len proper?)
(if proper?
(lambda (args)
(let ([v (make-vector len)])
(let f ([i 0] [args args])
(cond
[(fx= i len)
(if (null? args)
v
(error 'apply
"incorrect number of args to procedure"))]
[(pair? args)
(vector-set! v i (car args))
(f (fx+ i 1) (cdr args))]
[else (error 'apply "insufficient arguments")]))))
(lambda (args)
(let ([v (make-vector (fx+ len 1))])
(let f ([i 0] [args args])
(cond
[(fx= i len)
(vector-set! v i args)
v]
[(pair? args)
(vector-set! v i (car args))
(f (fx+ i 1) (cdr args))]
[else
(error 'apply "insufficient arguments")])))))))))
(define compile-lambda
(lambda (body r x)
(unless (fx>= (length body) 2)
(error 'eval "invalid function definition ~s" x))
(let ([fml* (car body)] [body* (cdr body)])
(verify-proper-lambda-bindings fml*)
(let ([r (extend-r fml* r)]
[ext (compile-lambda-binder fml*)])
(let ([body (compile-internal body* r x)])
(lambda (env)
(lambda args
(body (cons (ext args) env)))))))))
(define compile-if
(lambda (body r x)
(unless (fx= (length body) 3)
(error 'eval "invalid syntax ~s" x))
(let ([test (compile-expr (car body) r)]
[conseq (compile-expr (cadr body) r)]
[altern (compile-expr (caddr body) r)])
(lambda (env)
(if (test env)
(conseq env)
(altern env))))))
(define compile-when
(lambda (body r x)
(unless (fx>= (length body) 2)
(error 'eval "invalid syntax ~s" x))
(let ([test (compile-expr (car body) r)]
[conseq (compile-expr*->last (cdr body) r)])
(lambda (env)
(when (test env)
(conseq env))))))
(define compile-unless
(lambda (body r x)
(unless (fx>= (length body) 2)
(error 'eval "invalid syntax ~s" x))
(let ([test (compile-expr (car body) r)]
[altern (compile-expr*->last (cdr body) r)])
(lambda (env)
(unless (test env)
(altern env))))))
(define compile-quote
(lambda (body x)
(unless (fx= (length body) 1)
(error 'eval "invalid quote expression ~s" x))
(let ([v (car body)])
(lambda (env) v))))
(define compile-form
(lambda (k body r x)
(cond
[(eq? k 'quote) (compile-quote body x)]
[(eq? k 'lambda) (compile-lambda body r x)]
[(eq? k 'let) (compile-let body r x)]
[(eq? k 'if) (compile-if body r x)]
[(eq? k 'let*) (compile-let* body r x)]
[(eq? k 'letrec) (compile-letrec body r x)]
[(eq? k 'letrec*) (compile-letrec* body r x)]
[(eq? k 'set!) (compile-assign body r x)]
[(eq? k 'begin) (compile-begin body r x)]
[(eq? k 'or) (compile-or body r x)]
[(eq? k 'and) (compile-and body r x)]
[(eq? k 'cond) (compile-cond body r x)]
[(eq? k 'when) (compile-when body r x)]
[(eq? k 'unless) (compile-unless body r x)]
[(eq? k 'define)
(error 'eval "invalid definition in expression context in ~s" x)]
[else (error 'eval "unhandled keyword ~s" k)])))
(define compile-one-clause
(lambda (cls r x rest)
(unless (and (pair? cls) (list? cls))
(error 'eval "invalid cond clause ~s" cls))
(let ([len (length cls)])
(cond
[(fx= len 1)
(let ([q (compile-expr (car cls) r)])
(lambda (env)
(let ([t (q env)])
(if t t (rest env)))))]
[(and (fx= len 3) (eq? (cadr cls) '=>) (special? '=> r))
(let ([q (compile-expr (car cls) r)]
[f (compile-expr (caddr cls) r)])
(lambda (env)
(let ([t (q env)])
(if t ((f env) t) (rest env)))))]
[else
(let ([q (compile-expr (car cls) r)]
[d (compile-expr*->last (cdr cls) r)])
(lambda (env)
(if (q env)
(d env)
(rest env))))]))))
(define compile-last-cond-clause
(lambda (cls r x)
(unless (and (pair? cls) (list? cls))
(error 'eval "invalid syntax ~s" x))
(cond
[(and (eq? (car cls) 'else) (special? 'else r))
(when (null? (cdr cls))
(error 'eval "invalid syntax ~s" x))
(compile-expr*->last (cdr cls) r)]
[else
(compile-one-clause cls r x
(lambda (env) #f))])))
(define compile-cond
(lambda (cls* r x)
(cond
[(null? cls*) (lambda (env) #f)]
[(null? (cdr cls*))
(compile-last-cond-clause (car cls*) r x)]
[else
(compile-one-clause (car cls*) r x
(compile-cond (cdr cls*) r x))])))
(define compile-and
(lambda (ls r x)
(cond
[(null? ls) (lambda (env) #t)]
[(null? (cdr ls)) (compile-expr (car ls) r)]
[else
(let ([a (compile-expr (car ls) r)]
[d (compile-and (cdr ls) r x)])
(lambda (env)
(and (a env) (d env))))])))
(define compile-or
(lambda (ls r x)
(cond
[(null? ls) (lambda (env) #f)]
[(null? (cdr ls)) (compile-expr (car ls) r)]
[else
(let ([a (compile-expr (car ls) r)]
[d (compile-or (cdr ls) r x)])
(lambda (env)
(or (a env) (d env))))])))
(define compile-begin
(lambda (body r x)
(unless (pair? body) (error 'eval "invalid expression ~s" x))
(compile-expr*->last body r)))
(define compile-expr*->last
(lambda (body* r)
(let f ([a (car body*)] [d (cdr body*)])
(cond
[(null? d) (compile-expr a r)]
[else
(let ([a (compile-expr a r)])
(let ([d (compile-expr*->last d r)])
(lambda (env) (a env) (d env))))]))))
(define compile-expr*->assign
(lambda (body* r)
(let f ([i 0] [a (car body*)] [d (cdr body*)])
(cond
[(null? d)
(let ([v (compile-expr a r)])
(lambda (env)
(vector-set! (car env) i (v env))))]
[else
(let ([v (compile-expr a r)]
[d (f (fxadd1 i) (car d) (cdr d))])
(lambda (env)
(vector-set! (car env) i (v env))
(d env)))]))))
(define vector-assign!
(lambda (v i ls)
(unless (null? ls)
(vector-set! v i (car ls))
(vector-assign! v (fxadd1 i) (cdr ls)))))
(define build-letrec
(lambda (lhs* rhs* r body*)
(cond
[(null? lhs*) (compile-expr*->last body* r)]
[else
(let ([r (extend-r lhs* r)])
(let ([rhs* (compile-expr*->list rhs* r)]
[body (compile-expr*->last body* r)]
[n (length lhs*)]) ;?
(lambda (env)
(let ([v (make-vector n #f)])
(let ([env (cons v env)])
(vector-assign! v 0 (rhs* env))
(body env))))))])))
(define verify-bindings
(lambda (bind* x)
(unless (and (list? bind*)
(andmap
(lambda (x)
(and (list? x) (fx= (length x) 2) (symbol? (car x))))
bind*))
(error 'eval "invalid bindings in ~s" x))))
(define compile-letrec
(lambda (body r x)
(unless (fx>= (length body) 2)
(error 'eval "invalid syntax ~s" x))
(let ([bind* (car body)] [body* (cdr body)])
(build-letrec (map car bind*) (map cadr bind*) r body*))))
(define compile-letrec*
(lambda (body r x)
(unless (fx>= (length body) 2)
(error 'eval "invalid syntax ~s" x))
(let ([bind* (car body)] [body* (cdr body)])
(verify-bindings bind* x)
(if (null? bind*)
(compile-internal body* r x)
(let ([r (extend-r (map car bind*) r)])
(let ([rhs* (compile-expr*->assign (map cadr bind*) r)])
(let ([body (compile-internal body* r x)]
[n (length bind*)])
(lambda (env)
(let ([env (cons (make-vector n #f) env)])
(rhs* env)
(body env))))))))))
(define compile-let
(lambda (body r x)
(unless (fx>= (length body) 2)
(error 'eval "invalid syntax ~s" x))
(let ([bind* (car body)] [body* (cdr body)])
(verify-bindings bind* x)
(if (null? bind*)
(compile-internal body* r x)
(let ([rhs* (compile-expr*->list (map cadr bind*) r)])
(let ([r (extend-r (map car bind*) r)])
(let ([body (compile-internal body* r x)])
(lambda (env)
(body (cons (list->vector (rhs* env)) env))))))))))
(define compile-let*
(lambda (body r x)
(unless (fx>= (length body) 2)
(error 'eval "invalid syntax ~s" x))
(let ([bind* (car body)] [body* (cdr body)])
(verify-bindings bind* x)
(let f ([bind* bind*] [r r])
(cond
[(null? bind*) (compile-internal body* r x)]
[else
(let ([b (car bind*)])
(let ([lhs (car b)] [rhs (cadr b)])
(let ([rhs (compile-expr rhs r)])
(let ([r (extend-r (list lhs) r)])
(let ([rest (f (cdr bind* r))])
(lambda (env)
(let ([env (cons (vector (rhs env)) env)])
(rest env))))))))])))))
(define compile-expr*->list
(lambda (expr* r)
(when (null? expr*)
(error 'eval "this should nto happen"))
(let f ([a (car expr*)] [d (cdr expr*)])
(cond
[(null? d)
(let ([a (compile-expr a r)])
(lambda (env)
(cons (a env) '())))]
[else
(let ([a (compile-expr a r)]
[d (f (car d) (cdr d))])
(lambda (env)
(cons (a env) (d env))))]))))
(define compile-internal-aux
(lambda (x* r x lhs* rhs*)
(when (null? x*)
(error 'eval "no body in ~s" x))
(let ([a (car x*)] [d (cdr x*)])
(cond
[(and (pair? a)
(eq? (car a) 'define)
(special? 'define r)
(not (memq 'define lhs*)))
(unless (and (list? a) (fx= (length a) 3))
(error 'eval "invalid syntax ~s" a))
(let ([lhs (cadr a)] [rhs (caddr a)])
(unless (symbol? lhs)
(error 'eval "invalid id ~s in ~s" lhs x))
(when (memq lhs lhs*)
(error 'eval "duplicate definition for ~s in ~s ~s" lhs lhs* x))
(compile-internal-aux d r x
(cons lhs lhs*) (cons rhs rhs*)))]
[(and (pair? a)
(eq? (car a) 'begin)
(special? 'begin r)
(not (memq 'begin lhs*)))
(let ([rest (cdr a)])
(unless (list? rest)
(error 'eval "invalid begin syntax ~s" a))
(compile-internal-aux (append rest d) r x lhs* rhs*))]
[else
(build-letrec (reverse lhs*) (reverse rhs*) r x*)]))))
(define special?
(lambda (x r)
(cond
[(top-level-bound? x) #f]
[(lookup x r) #f]
[else #t])))
(define compile-internal
(lambda (x* r x)
(compile-internal-aux x* r x '() '())))
(define lookup
(lambda (x r)
(let f ([r r] [i 0])
(cond
[(null? r) #f]
[else
(or (let f ([ls (car r)] [j 0])
(cond
[(null? ls) #f]
[(pair? ls)
(if (eq? (car ls) x)
(cons i j)
(f (cdr ls) (fx+ j 1)))]
[(eq? ls x) (cons i j)]
[else #f]))
(f (cdr r) (fx+ i 1)))]))))
(define compile-assign
(lambda (body r x)
(unless (fx= (length body) 2)
(error 'eval "invalid assignment ~s" x))
(unless (symbol? (car body))
(error 'eval "invalid syntax ~s" x))
(let ([val (compile-expr (cadr body) r)]
[var (car body)])
(cond
[(lookup var r) =>
(lambda (p)
(build-lexical-assignment p val))]
[(top-level-bound? var)
(lambda (env)
(set-top-level-value! var (val env)))]
[(keyword? var)
(error 'eval "invalid assignment to keyword in ~s" x)]
[else
(lambda (env)
(set-top-level-value! var (val env)))]))))
(define list-ref
(lambda (ls i)
(cond
[(null? ls) (error 'list-ref "index out of range")]
[(fxzero? i) (car ls)]
[else (list-ref (cdr ls) (fx- i 1))])))
(define build-lexical-assignment
(lambda (p val)
(lambda (env)
(vector-set! (list-ref env (car p)) (cdr p) (val env)))))
(define build-lexical-reference
(lambda (p)
(lambda (env)
(vector-ref (list-ref env (car p)) (cdr p)))))
(define compile-expr
(lambda (x r)
(cond
[(self-evaluating? x) (lambda (env) x)]
[(symbol? x)
(cond
[(lookup x r) => build-lexical-reference]
[(top-level-bound? x)
(lambda (env) (top-level-value x))]
[(keyword? x) (error 'eval "invalid reference to keyword ~s" x)]
[else
(lambda (env)
(if (top-level-bound? x)
(top-level-value x)
(error 'eval "reference to unbound variable ~s" x)))])]
[(not (list? x)) (error 'eval "invalid expression ~s" x)]
[(and (symbol? (car x)) (keyword? (car x)) (special? (car x) r))
(compile-form (car x) (cdr x) r x)]
[else
(let ([op (compile-expr (car x) r)]
[rand* (cdr x)]
[n (length (cdr x))])
(cond
[(fx= n 0)
(lambda (env) ((op env)))]
[(fx= n 1)
(let ([r1 (compile-expr (car rand*) r)])
(lambda (env)
((op env) (r1 env))))]
[(fx= n 2)
(let ([r1 (compile-expr (car rand*) r)]
[r2 (compile-expr (cadr rand*) r)])
(lambda (env)
((op env) (r1 env) (r2 env))))]
[(fx= n 3)
(let ([r1 (compile-expr (car rand*) r)]
[r2 (compile-expr (cadr rand*) r)]
[r3 (compile-expr (caddr rand*) r)])
(lambda (env)
((op env) (r1 env) (r2 env) (r3 env))))]
[(fx= n 4)
(let ([r1 (compile-expr (car rand*) r)]
[r2 (compile-expr (cadr rand*) r)]
[r3 (compile-expr (caddr rand*) r)]
[r4 (compile-expr (cadddr rand*) r)])
(lambda (env)
((op env) (r1 env) (r2 env) (r3 env) (r4 env))))]
[else
(let ([r1 (compile-expr (car rand*) r)]
[r2 (compile-expr (cadr rand*) r)]
[r3 (compile-expr (caddr rand*) r)]
[r4 (compile-expr (cadddr rand*) r)]
[r* (compile-expr*->list (cddddr rand*) r)])
(lambda (env)
($apply (op env) (r1 env) (r2 env) (r3 env) (r4 env)
(r* env))))]))])))
(define eval-top
(lambda (x)
(cond
[(and (pair? x) (eq? (car x) 'define) (not (top-level-bound? 'define)))
(unless (and (list? x) (fx= (length x) 3))
(error 'eval "invalid syntax ~s" x))
(let ([var (cadr x)] [val (caddr x)])
(unless (symbol? var) (error 'eval "invalid syntax ~s" x))
(let ([val (compile-expr val '())])
(set-top-level-value! var (val '()))))]
[(and (pair? x) (eq? (car x) 'begin) (not (top-level-bound? 'begin)))
(unless (list? x)
(error 'eval "invalid syntax ~s" x))
(letrec ([f
(lambda (x x*)
(if (null? x*)
(eval-top x)
(begin
(eval-top x)
(f (car x*) (cdr x*)))))])
(let ([d (cdr x)])
(unless (null? d)
(f (car d) (cdr d)))))]
[else
((compile-expr x '()) '())])))
($pcb-set! eval eval-top))
($pcb-set! current-eval
(make-parameter eval
(lambda (f)
(unless (procedure? f)
(error 'current-eval "not a procedure ~s" f))
f)))
(let ()
(define read-and-eval
(lambda (p)
(let ([x (read p)])
(unless (eof-object? x)
((current-eval) x)
(read-and-eval p)))))
($pcb-set! load
(lambda (x)
(unless (string? x)
(error 'load "~s is not a string" x))
(let ([p (open-input-file x)])
(read-and-eval p)
(close-input-port p)))))
#!eof
(define test-suite
(lambda (x)
(printf "performing ~a tests\n" (car x))
(for-each
(lambda (t)
(define x (car t))
(write x)
(newline)
(unless (equal? (caddr t) "")
(let ([v (eval x)] [w (interpret x)])
(unless (equal? v w)
(error #f "got ~s, should be ~s" v w)))))
(cdr x))))
(define test-file
(lambda (x)
(with-input-from-file x
(lambda ()
(let f ()
(let ([x (read)])
(unless (eof-object? x)
(test-suite (cdr x))
(f))))))))
(define fxadd1 (lambda (n) (fx+ n 1)))
(define fxsub1 (lambda (n) (fx- n 1)))
(define fixnum->char integer->char)
(define char->fixnum char->integer)
(define $apply apply)
(define char= char=?)
(define char< char<?)
(define char<= char<=?)
(define char> char>?)
(define char>= char>=?)
(for-each
test-file
'("tests-1.1-req.scm"
"tests-1.2-req.scm"
"tests-1.3-req.scm"
"tests-1.4-req.scm"
"tests-1.5-req.scm"
"tests-1.6-req.scm"
"tests-1.7-req.scm"
"tests-1.8-req.scm"
"tests-1.9-req.scm"
"tests-2.1-req.scm"
"tests-2.2-req.scm"
"tests-2.3-req.scm"
"tests-2.4-req.scm"
"tests-2.6-req.scm"
"tests-2.8-req.scm"
"tests-2.9-req.scm"
"tests-3.1-req.scm"
"tests-3.2-req.scm"
"tests-3.3-req.scm"
"tests-3.4-req.scm"
"tests-4.1-req.scm"
"tests-4.2-req.scm"
"tests-4.3-req.scm"))

644
src/libeval-5.3.ss Normal file
View File

@ -0,0 +1,644 @@
(let ()
(define verify-proper-lambda-bindings
(lambda (fml*)
(void)))
(define keyword?
(lambda (x)
(memq x
'(lambda let let* letrec letrec* if quote when unless
set! begin define or and cond case))))
(define self-evaluating?
(lambda (x)
(or (fixnum? x) (null? x) (boolean? x) (char? x) (string? x))))
(define extend-r
(lambda (fml* r)
(cons fml* r)))
(define classify
(lambda (fml* k)
(let f ([fml* fml*] [i 0])
(cond
[(null? fml*) (k i #t)]
[(pair? fml*) (f (cdr fml*) (fx+ i 1))]
[else (k i #f)]))))
(define compile-lambda-binder
(lambda (fml*)
(classify fml*
(lambda (len proper?)
(if proper?
(lambda (args)
(let ([v (make-vector len)])
(let f ([i 0] [args args])
(cond
[(fx= i len)
(if (null? args)
v
(error 'apply
"incorrect number of args to procedure"))]
[(pair? args)
(vector-set! v i (car args))
(f (fx+ i 1) (cdr args))]
[else (error 'apply "insufficient arguments")]))))
(lambda (args)
(let ([v (make-vector (fx+ len 1))])
(let f ([i 0] [args args])
(cond
[(fx= i len)
(vector-set! v i args)
v]
[(pair? args)
(vector-set! v i (car args))
(f (fx+ i 1) (cdr args))]
[else
(error 'apply "insufficient arguments")])))))))))
(define compile-lambda
(lambda (body r x)
(unless (fx>= (length body) 2)
(error 'eval "invalid function definition ~s" x))
(let ([fml* (car body)] [body* (cdr body)])
(verify-proper-lambda-bindings fml*)
(let ([r (extend-r fml* r)]
[ext (compile-lambda-binder fml*)])
(let ([body (compile-internal body* r x)])
(lambda (env)
(lambda args
(body (cons (ext args) env)))))))))
(define compile-if
(lambda (body r x)
(unless (fx= (length body) 3)
(error 'eval "invalid syntax ~s" x))
(let ([test (compile-expr (car body) r)]
[conseq (compile-expr (cadr body) r)]
[altern (compile-expr (caddr body) r)])
(lambda (env)
(if (test env)
(conseq env)
(altern env))))))
(define compile-case
(lambda (body r x)
(unless (fx>= (length body) 2)
(error 'eval "invalid expression ~s" x))
(let ([v
(compile-expr (car body) r)]
[body
(compile-case-body (cdr body) r x)])
(lambda (env)
(body (v env) env)))))
(define compile-case-body
(lambda (cls* r x)
(cond
[(null? cls*) (error 'eval "empty body in ~s" x)]
[(null? (cdr cls*))
(compile-case-last-clause (car cls*) r x)]
[else
(compile-case-one-clause (car cls*) r x
(compile-case-body (cdr cls*) r x))])))
(define compile-case-last-clause
(lambda (cls r x)
(cond
[(and (pair? cls)
(eq? (car cls) 'else)
(special? 'else r))
(unless (and (list? cls) (fx>= (length cls) 2))
(error 'eval "invalid else clause in ~s" x))
(let ([body* (compile-expr*->last (cdr cls) r)])
(lambda (v env)