imported compiler1

This commit is contained in:
Abdulaziz Ghuloum 2006-11-23 19:38:26 -05:00
parent d3313cd737
commit 3e7726203a
134 changed files with 25820 additions and 109334 deletions

View File

@ -1 +1,3 @@
*.s
*.tmp
*.out

View File

@ -1,67 +0,0 @@
#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);
}

View File

@ -1,6 +1,77 @@
(load "chez-compat.ss")
(load "libintelasm-5.8.ss")
(load "libfasl-6.0.ss")
(define-record code (code-size reloc-size closure-size code-vec reloc-vec))
(define make-code
(let ([make-code make-code])
(lambda (code-size reloc-size closure-size)
(printf "reloc=~s\n" reloc-size)
(let ([code-size (fxsll (fxsra (fx+ code-size 3) 2) 2)])
(make-code
(fxsra code-size 2)
(fxsra reloc-size 2)
closure-size
(make-vector code-size (cons 'byte 0))
(make-vector (fxsra reloc-size 2)))))))
(define set-code-byte!
(lambda (code idx byte)
(vector-set! (code-code-vec code) idx (cons 'byte byte))))
(define set-code-word!
(lambda (code idx x)
(cond
[(fixnum? x)
(set-code-byte! code (fx+ idx 0) (fxsll (fxlogand x #x3F) 2))
(set-code-byte! code (fx+ idx 1) (fxlogand (fxsra x 6) #xFF))
(set-code-byte! code (fx+ idx 2) (fxlogand (fxsra x 14) #xFF))
(set-code-byte! code (fx+ idx 3) (fxlogand (fxsra x 22) #xFF))]
[else (error 'set-code-word! "unhandled ~s" x)])))
(define set-code-object!
(lambda (code obj code-idx reloc-idx)
(let ([v (code-reloc-vec code)])
(vector-set! v reloc-idx (list 'object code-idx obj)))))
(define set-code-object+offset/rel!
(lambda (code obj code-idx obj-idx reloc-idx)
(let ([v (code-reloc-vec code)])
(vector-set! v reloc-idx
(list 'object+off/rel code-idx obj obj-idx))
(vector-set! v (fxadd1 reloc-idx) '(skip)))))
(define set-code-object+offset!
(lambda (code obj code-idx obj-idx reloc-idx)
(let ([v (code-reloc-vec code)])
(vector-set! v reloc-idx
(list 'object+off code-idx obj obj-idx))
(vector-set! v (fxadd1 reloc-idx) '(skip)))))
(define make-code-executable!
(lambda (x) (void)))
(define eval-code
(lambda (code)
(with-output-to-file "stst.fasl"
(lambda ()
(fasl-write code))
'replace)
(let ([rv (system "runtime/ikarus stst.fasl > stst.tmp")])
(unless (zero? rv)
(error 'eval-code "Failed to run: ~s" rv)))
(with-input-from-file "stst.tmp" read)))
(let ()
(define verbose #f)
(define verbose #t)
(define passed-tests 0)
(define all-tests 0)
@ -9,9 +80,8 @@
(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)])
(let* ([code (car (list*->code* (list code-ls)))]
[v (eval-code code)])
(when verbose (printf "evaluated\n"))
(cond
[(equal? v val)
@ -21,10 +91,41 @@
(error 'test-code
"expected ~s, got ~s" val v)]))))
(printf "testing ... \n")
(test-code
'([ret])
'([movl (int 0) %eax]
[ret])
0)
(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))
(test-code
'([movl (obj+ (1 2 3) 3) %eax]
[movl (disp (int 0) %eax) %eax]
[ret])
'(2 3))
(test-code
'([movl (int 40) %eax]
[ret])
@ -282,31 +383,31 @@
[ret])
'list)
(test-code
'([movl (obj list) %eax]
[movl (disp (int 6) %eax) %eax] ; symbol value
[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 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) (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]
@ -362,24 +463,24 @@
`([movl (int 10) %eax]
[cmpl (int 8) %eax]
[jne (label ,L1)]
[movl (obj #f) %eax]
[movl (obj 0) %eax]
[ret]
[label ,L1]
[movl (obj #t) %eax]
[movl (obj 1) %eax]
[ret])
#t))
1))
(let ([L1 (gensym)])
(test-code
`([movl (int 40) %eax]
[cmpl (obj 10) %eax]
[je (label ,L1)]
[movl (obj #f) %eax]
[movl (obj 0) %eax]
[ret]
[label ,L1]
[movl (obj #t) %eax]
[movl (obj 1) %eax]
[ret])
#t))
1))
(let ([L1 (gensym)])
(test-code
@ -387,24 +488,24 @@
[movl (int 30) %ebx]
[cmpl %ebx %eax]
[jge (label ,L1)]
[movl (obj #f) %eax]
[movl (obj 0) %eax]
[ret]
[label ,L1]
[movl (obj #t) %eax]
[movl (obj 1) %eax]
[ret])
#t))
1))
(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]
[movl (obj 0) %eax]
[ret]
[label ,L1]
[movl (obj #t) %eax]
[movl (obj 1) %eax]
[ret])
#t))
1))
(test-code
'([movl (int 40) (disp (int -4) %esp)]
@ -429,13 +530,13 @@
[cmpl (int 70) (disp (int -1004) %esp)]
[jle (label ,L1)]
[addl (int -1000) %esp]
[movl (obj #f) %eax]
[movl (obj 0) %eax]
[ret]
[label ,L1]
[addl (int -1000) %esp]
[movl (obj #t) %eax]
[movl (obj 1) %eax]
[ret])
#t))
1))
(let ([L1 (gensym)])
(test-code
@ -444,13 +545,13 @@
[cmpl (int 7000) (disp (int -1004) %esp)]
[jle (label ,L1)]
[addl (int -1000) %esp]
[movl (obj #f) %eax]
[movl (obj 0) %eax]
[ret]
[label ,L1]
[addl (int -1000) %esp]
[movl (obj #t) %eax]
[movl (obj 1) %eax]
[ret])
#t))
1))
(let ([L1 (gensym)])
(test-code
@ -458,12 +559,12 @@
[movl (int 70) %ebx]
[cmpl (disp (int -4) %esp) %ebx]
[jge (label ,L1)]
[movl (obj #f) %eax]
[movl (obj 0) %eax]
[ret]
[label ,L1]
[movl (obj #t) %eax]
[movl (obj 1) %eax]
[ret])
#t))
1))
(let ([L_fact (gensym)] [L1 (gensym)])

View File

@ -1,171 +0,0 @@
;;; 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
)

View File

@ -1 +1 @@
2006-07-19
2006-07-27

View File

@ -3,64 +3,32 @@
[(_ name val)
(set-top-level-value! 'name val)]))
(define primitive-set! set-top-level-value!)
(define (immediate? x)
(or (fixnum? x)
(null? x)
(char? x)
(boolean? x)
(eof-object? x)
(eq? x (void))))
(define-syntax add1 syntax-error)
(define fxadd1
(lambda (x)
(import scheme)
(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)
(import scheme)
(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=?)

View File

@ -1,399 +0,0 @@
#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);
}
}

View File

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

View File

@ -1,572 +0,0 @@
#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));