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

* bug in collector causing dirty bits for code objects with younger reloc 

vectors to be unset incorrectly.  The bug was in using || instead
  of | when computing the dirty pattern.
This commit is contained in:
Abdulaziz Ghuloum 2007-02-22 21:58:38 -05:00
parent 0bd88991cb
commit 819a3ca1c1
12 changed files with 2237 additions and 100 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
benchmarks/prefix/prefix-ikarus.scm
View File

@ -493,4 +493,5 @@
)
)
;(assembler-output #t)
;------------------------------------------------------------------------------

1590
benchmarks/results.Larceny-r6rs
View File

File diff suppressed because it is too large Load Diff

8
bin/Makefile
View File

@ -7,12 +7,13 @@ all: ikarus
ikarus: ikarus-collect.o ikarus-runtime.o ikarus-main.o ikarus-fasl.o \
ikarus-exec.o ikarus-print.o ikarus-enter.o ikarus-symbol-table.o \
ikarus-weak-pairs.o ikarus-numerics.o ikarus-flonums.o
ikarus-weak-pairs.o ikarus-numerics.o ikarus-flonums.o \
verify-integrity.o
$(CC) $(LDFLAGS) -o ikarus \
ikarus-main.o ikarus-runtime.o \
ikarus-fasl.o ikarus-exec.o ikarus-print.o ikarus-enter.o \
ikarus-symbol-table.o ikarus-collect.o ikarus-weak-pairs.o \
ikarus-numerics.o ikarus-flonums.o
ikarus-numerics.o ikarus-flonums.o verify-integrity.o
ikarus-main.o: ikarus-main.c ikarus.h
$(CC) $(CFLAGS) -c ikarus-main.c
@ -27,6 +28,9 @@ ikarus-runtime.o: ikarus-runtime.c ikarus.h
ikarus-fasl.o: ikarus-fasl.c ikarus.h
$(CC) $(CFLAGS) -c ikarus-fasl.c
verify-integrity.o: verify-integrity.c ikarus.h
$(CC) $(CFLAGS) -c verify-integrity.c
ikarus-exec.o: ikarus-exec.c ikarus.h
$(CC) $(CFLAGS) -c ikarus-exec.c

BIN
bin/ikarus
View File

Binary file not shown.

53
bin/ikarus-collect.c
View File

@ -51,9 +51,9 @@ typedef struct{
#define meta_count 5
static int extension_amount[meta_count] = {
4 * pagesize,
1 * pagesize,
4 * pagesize,
1 * pagesize,
1 * pagesize,
1 * pagesize,
1 * pagesize
};
@ -187,6 +187,7 @@ gc_alloc_new_data(int size, int old_gen, gc_t* gc){
static inline ikp
gc_alloc_new_code(int size, int old_gen, gc_t* gc){
assert(size == align(size));
if(size < pagesize){
return meta_alloc(size, old_gen, gc, meta_code);
} else {
@ -196,6 +197,7 @@ gc_alloc_new_code(int size, int old_gen, gc_t* gc){
qupages_t* p = ik_malloc(sizeof(qupages_t));
p->p = mem;
p->q = mem+size;
bzero(mem+size, memreq-size);
p->next = gc->queues[meta_code];
gc->queues[meta_code] = p;
return mem;
@ -285,10 +287,13 @@ static void deallocate_unused_pages(gc_t*);
static void fix_new_pages(gc_t* gc);
extern void verify_integrity(ikpcb* pcb, char*);
ikpcb*
ik_collect(int mem_req, ikpcb* pcb){
#ifndef NDEBUG
verify_integrity(pcb, "entry");
#endif
{ /* ACCOUNTING */
int bytes = ((int)pcb->allocation_pointer) -
((int)pcb->heap_base);
@ -440,6 +445,9 @@ ik_collect(int mem_req, ikpcb* pcb){
ref(x, 0) = (ikp)(0x1234FFFF);
x+=wordsize;
}
#endif
#ifndef NDEBUG
verify_integrity(pcb, "exit");
#endif
return pcb;
}
@ -893,12 +901,7 @@ add_object_proc(gc_t* gc, ikp x)
if(is_fixnum(x)){
return x;
}
#ifndef NDEBUG
if(x == forward_ptr){
fprintf(stderr, "GOTCHA\n");
exit(-1);
}
#endif
assert(x != forward_ptr);
int tag = tagof(x);
if(tag == immediate_tag){
return x;
@ -908,6 +911,9 @@ add_object_proc(gc_t* gc, ikp x)
/* already moved */
return ref(x, wordsize-tag);
}
if(x == (ikp)0x07a3f035){
fprintf(stderr, "FST=0x%08x\n", (int)fst);
}
unsigned int t = gc->segment_vector[page_index(x)];
int gen = t & gen_mask;
if(gen > gc->collect_gen){
@ -954,6 +960,7 @@ add_object_proc(gc_t* gc, ikp x)
else if(tag == vector_tag){
if(is_fixnum(fst)){
/* real vector */
//fprintf(stderr, "X=0x%08x, FST=0x%08x\n", (int)x, (int)fst);
int size = (int)fst;
assert(size >= 0);
int memreq = align(size + disp_vector_data);
@ -1063,6 +1070,7 @@ add_object_proc(gc_t* gc, ikp x)
}
else {
fprintf(stderr, "unhandled vector with fst=0x%08x\n", (int)fst);
assert(0);
exit(-1);
}
}
@ -1095,7 +1103,7 @@ add_object_proc(gc_t* gc, ikp x)
static void
relocate_new_code(ikp x, gc_t* gc){
ikp relocvector = ref(x, disp_code_reloc_vector);
relocvector = add_object(gc, relocvector, "reloc");
relocvector = add_object(gc, relocvector, "relocvec");
ref(x, disp_code_reloc_vector) = relocvector;
int relocsize = (int)ref(relocvector, off_vector_length);
ikp p = relocvector + off_vector_data;
@ -1107,8 +1115,12 @@ relocate_new_code(ikp x, gc_t* gc){
int code_off = r >> 2;
if(tag == 0){
/* undisplaced pointer */
#ifndef NDEBUG
// fprintf(stderr, "r=0x%08x code_off=%d reloc_size=0x%08x\n",
// r, code_off, relocsize);
#endif
ikp old_object = ref(p, wordsize);
ikp new_object = add_object(gc, old_object, "reloc");
ikp new_object = add_object(gc, old_object, "reloc1");
ref(code, code_off) = new_object;
p += (2*wordsize);
}
@ -1116,14 +1128,19 @@ relocate_new_code(ikp x, gc_t* gc){
/* displaced pointer */
int obj_off = unfix(ref(p, wordsize));
ikp old_object = ref(p, 2*wordsize);
ikp new_object = add_object(gc, old_object, "reloc");
ikp new_object = add_object(gc, old_object, "reloc2");
ref(code, code_off) = new_object + obj_off;
p += (3 * wordsize);
}
else if(tag == 3){
/* displaced relative pointer */
int obj_off = unfix(ref(p, wordsize));
ikp obj = add_object(gc, ref(p, 2*wordsize), "reloc");
ikp obj = ref(p, 2*wordsize);
#ifndef NDEBUG
//fprintf(stderr, "obj=0x%08x, obj_off=0x%08x\n", (int)obj,
// obj_off);
#endif
obj = add_object(gc, obj, "reloc3");
ikp displaced_object = obj + obj_off;
ikp next_word = code + code_off + wordsize;
ikp relative_distance = displaced_object - (int)next_word;
@ -1137,7 +1154,7 @@ relocate_new_code(ikp x, gc_t* gc){
else {
fprintf(stderr, "invalid rtag %d in 0x%08x\n", tag, r);
exit(-1);
}
}
}
}
@ -1610,16 +1627,22 @@ fix_new_pages(gc_t* gc){
if(is_fixnum(x) || (tagof(x) == immediate_tag)){
/* do nothing */
} else {
code_d = code_d || segment_vec[page_index(x)];
code_d = code_d | segment_vec[page_index(x)];
}
vp += wordsize;
}
code_d = (code_d & meta_dirty_mask) >> meta_dirty_shift;
int j = ((int)p - (int)page_base)/cardsize;
assert(j < cards_per_page);
d = d | (code_d<<(j*meta_dirty_shift));
p += align(disp_code_data + unfix(ref(p, disp_code_code_size)));
}
}
#ifndef NDEBUG
fprintf(stderr, " %p = 0x%08x & 0x%08x = 0x%08x\n",
page_base, d, cleanup_mask[page_gen], d &
cleanup_mask[page_gen]);
#endif
dirty_vec[i] = d & cleanup_mask[page_gen];
}
else {

4
bin/ikarus-runtime.c
View File

@ -725,9 +725,11 @@ ik_dump_dirty_vector(ikpcb* pcb){
ikp
ikrt_make_code(ikp codesizeptr, ikp freevars, ikp rvec, ikpcb* pcb){
assert((fx_mask & (int)codesizeptr) == 0);
int code_size = unfix(codesizeptr);
int memreq = align_to_next_page(code_size + disp_code_data);
ikp mem = ik_mmap_code(memreq, 0, pcb);
bzero(mem, memreq);
ref(mem, 0) = code_tag;
ref(mem, disp_code_code_size) = codesizeptr;
ref(mem, disp_code_freevars) = freevars;
@ -918,7 +920,7 @@ ikrt_fork(){
ikp
ikrt_waitpid(ikp pid){
int status;
pid_t t = waitpid(unfix(pid), &status, 0);
/*pid_t t = */ waitpid(unfix(pid), &status, 0);
return fix(status);
}

183
bin/verify-integrity.c Normal file
View File

@ -0,0 +1,183 @@
#include "ikarus.h"
#include <stdlib.h>
#include <assert.h>
static int
page_idx(unsigned char* x){
unsigned int xi = (unsigned int) x;
return xi >> pageshift;
}
#define fixnum_mask 3
#define pmask 7
#ifndef NDEBUG
static int isa_fixnum(ikp x){
return ((fixnum_mask & (int)x) == 0);
}
static int isa_vector(ikp x){
return ( (tagof(x) == vector_tag) &&
isa_fixnum(ref(x, -vector_tag)));
}
#endif
static void
verify_code(unsigned char* x, unsigned char* base, unsigned int* svec, unsigned int* dvec){
assert(ref(x, 0) == code_tag);
ikp rvec = ref(x, disp_code_reloc_vector);
assert(isa_vector(rvec));
ikp codesize = ref(x, disp_code_code_size);
codesize += 0;
assert(unfix(codesize) >= 0);
assert(isa_fixnum(codesize));
ikp freevars = ref(x, disp_code_freevars);
freevars += 0;
assert(isa_fixnum(freevars));
assert(unfix(freevars) >= 0);
unsigned int rs = svec[page_idx(rvec) - page_idx(base)];
unsigned int cs = svec[page_idx(x) - page_idx(base)];
int cgen = cs&gen_mask;
int rgen = rs&gen_mask;
if(rgen < cgen){
unsigned int d = dvec[page_idx(x) - page_idx(base)];
d = d & d;
//int off = (((int)x) - align_to_prev_page(x)) / card_size;
//int card_mark = (d >> off) & 0xF;
assert(d != 0);
}
}
static void
verify_object(ikp x, unsigned char* base, unsigned int* svec, unsigned int* dvec){
}
static unsigned char*
verify_code_small(unsigned char* p, unsigned int s, unsigned int d,
unsigned char* base, unsigned int* svec, unsigned int* dvec){
ikp q = p + pagesize;
while(p < q){
ikp fst = ref(p, 0);
if(fst == code_tag){
assert(is_fixnum(ref(p, disp_code_code_size)));
int code_size = unfix(ref(p, disp_code_code_size));
assert(code_size >= 0);
verify_code(p, base, svec, dvec);
p+=align(code_size + disp_code_data);
} else {
p = q;
}
}
if(p != q){
fprintf(stderr, "code extended beyond a page in %p, %p\n", p, q);
assert(0);
}
return q;
}
static unsigned char*
verify_code_large(unsigned char* p, unsigned int s, unsigned int d,
unsigned char* base, unsigned int* svec, unsigned int* dvec){
ikp fst = ref(p, 0);
fst += 0;
assert(fst == code_tag);
int code_size = unfix(ref(p, disp_code_code_size));
assert(code_size >= 0);
verify_code(p, base, svec, dvec);
assert(align(code_size+disp_code_data) >= pagesize);
ikp end = p + code_size + disp_code_data;
return((unsigned char*)align_to_next_page(end));
}
static unsigned char*
verify_code_page(unsigned char* p, unsigned int s, unsigned int d,
unsigned char* base, unsigned int* svec, unsigned int* dvec){
ikp fst = ref(p, 0);
fst += 0;
assert (fst == code_tag);
int code_size = unfix(ref(p, disp_code_code_size));
assert(code_size >= 0);
int obj_size = align(code_size + disp_code_data);
unsigned char* result;
if(obj_size <= pagesize){
result = verify_code_small(p,s,d,base,svec,dvec);
} else {
result = verify_code_large(p,s,d,base,svec,dvec);
}
// fprintf(stderr, "code verify incomplete\n");
return result;
}
static unsigned char*
verify_pointers_page(unsigned char* p, unsigned int s, unsigned int d,
unsigned char* base, unsigned int* svec, unsigned int* dvec){
{
int i = 0;
while(i < pagesize){
verify_object(ref(p, i), base, svec, dvec);
i += wordsize;
}
}
//fprintf(stderr, "pointers verif incomplete\n");
return p+pagesize;
}
static unsigned char*
verify_page(unsigned char* p, unsigned char* base, unsigned int* svec, unsigned int* dvec){
int idx = page_idx(p) - page_idx(base);
unsigned int s = svec[idx];
unsigned int d = dvec[idx];
// if(s & dealloc_mask){
// return p+pagesize;
// }
int type = s & type_mask;
if(type == hole_type){
return p+pagesize;
}
assert((s & new_gen_mask) == 0);
if(type == code_type){
return verify_code_page(p,s,d,base,svec,dvec);
}
else if(type == pointers_type){
return verify_pointers_page(p,s,d,base,svec,dvec);
}
else if(type == data_type){
/* nothing to do for data */
return p+pagesize;
}
else if(type == mainheap_type){
/* nothing to do for main heap */
return p+pagesize;
}
else if(type == mainstack_type){
/* nothing to do for main stack */
return p+pagesize;
}
fprintf(stderr, "type=0x%08x\n", type);
exit(-1);
}
void
verify_integrity(ikpcb* pcb, char* where){
fprintf(stderr, "verifying in %s...\n", where);
unsigned char* mem_base = pcb->memory_base;
unsigned char* mem_end = pcb->memory_end;
unsigned int* seg_vec = pcb->segment_vector_base;
unsigned int* dir_vec = pcb->dirty_vector_base;
unsigned char* mem = mem_base;
while(mem < mem_end){
mem = verify_page(mem, mem_base, seg_vec, dir_vec);
}
fprintf(stderr, "verify_ok in %s\n", where);
}

BIN
src/ikarus.boot
View File

Binary file not shown.

473
src/libaltcogen.ss
View File

@ -154,6 +154,14 @@
[$fx< p]
[$fx<= p]
[$fx= p]
[- v]
[+ v]
[= p]
[< p]
[<= p]
[> p]
[>= p]
[zero? p]
[$char= p]
@ -171,6 +179,8 @@
[cdr v]
[$car v]
[$cdr v]
[set-car! e]
[set-cdr! e]
[$set-car! e]
[$set-cdr! e]
@ -831,6 +841,24 @@
;;; case with vectors and records.
(prm 'mset x (K off) v)
(dirty-vector-set x))))]
[(set-car! set-cdr!)
(let ([off (if (eq? op 'set-car!)
(- disp-car pair-tag)
(- disp-cdr pair-tag))])
(tbind ([x (Value (car arg*))]
[v (Value (cadr arg*))])
(seq* ;;; car/cdr addresses are in the same
;;; card as the pair address, so no
;;; adjustment is necessary as was the
;;; case with vectors and records.
(make-conditional
(tag-test x pair-mask pair-tag)
(make-seq
(prm 'mset x (K off) v)
(dirty-vector-set x))
(Effect
(make-funcall (make-primref 'error)
(list (K op) (K "~s is not a pair") x)))))))]
[($string-set!)
(tbind ([x (Value (car arg*))])
(let ([i (cadr arg*)]
@ -957,6 +985,14 @@
[(bwp-object?) (prm '= (Value (car arg*)) (K bwp-object))]
[(neq?) (make-primcall '!= (map Value arg*))]
[($fxzero?) (prm '= (Value (car arg*)) (K 0))]
[(zero?)
(tbind ([x (Value (car arg*))])
(make-conditional
(tag-test x fixnum-mask fixnum-tag)
(prm '= x (K 0))
(prm '!=
(make-funcall (Value (make-primref 'zero?)) (list x))
(Value (K #f)))))]
[($unbound-object?) (prm '= (Value (car arg*)) (K unbound))]
[(pair?)
(tag-test (Value (car arg*)) pair-mask pair-tag)]
@ -1023,6 +1059,56 @@
(prm '<= (Value (car arg*)) (Value (cadr arg*)))]
[($fx>= $char>=)
(prm '>= (Value (car arg*)) (Value (cadr arg*)))]
[(= < <= > >=)
(unless (= (length arg*) 2)
(error who "only binary ~s for now" op))
(let ([cmp?
(case op
[(=) =]
[(<) <]
[(<=) <=]
[(>) >]
[(>=) >=]
[else (error who "unhandled op ~s" op)])])
(let ([a (car arg*)] [b (cadr arg*)])
(define (call a b)
(prm '!= (Value (K #f))
(make-funcall
(Value (make-primref op))
(list a b))))
(record-case a
[(constant i)
(cond
[(fixnum? i)
(record-case b
[(constant j)
(if (fixnum? j)
(make-constant (cmp? i j))
(call (Value a) (Value b)))]
[else
(tbind ([b (Value b)])
(make-conditional
(tag-test b fixnum-mask fixnum-tag)
(prm op (Value a) b)
(call (Value a) b)))])]
[else
(call (Value a) (Value b))])]
[else
(record-case b
[(constant j)
(if (fixnum? j)
(tbind ([a (Value a)])
(make-conditional
(tag-test a fixnum-mask fixnum-tag)
(prm op a (Value b))
(call a (Value b))))
(call (Value a) (Value b)))]
[else
(tbind ([a (Value a)] [b (Value b)])
(make-conditional
(tag-test (prm 'logor a b) fixnum-mask fixnum-tag)
(prm op a b)
(call a b)))])])))]
[else (error who "pred prim ~a not supported" op)])]
[(mvcall rator x)
(make-mvcall (Value rator) (Clambda x Pred))]
@ -1038,6 +1124,30 @@
(K (+ known-amt (sub1 object-alignment))))
(K align-shift))
(K align-shift)))
(define (remove-complex* ls k)
(let-values ([(lhs* rhs* arg*)
(let f ([ls ls])
(cond
[(null? ls) (values '() '() '())]
[else
(let-values ([(lhs* rhs* arg*)
(f (cdr ls))])
(let ([a (car ls)])
(cond
[(or (var? a) (complex? a))
(values lhs* rhs* (cons a arg*))]
[else
(let ([t (unique-var 'tmp)])
(values
(cons t lhs*)
(cons (Value a) rhs*)
(cons t arg*)))])))]))])
(cond
[(null? lhs*)
(k arg*)]
[else
(make-bind lhs* rhs*
(k arg*))])))
;;; value
(define (Value x)
(record-case x
@ -1269,12 +1379,15 @@
(tbind ([i (Value i)])
(prm 'logor
(prm 'sll
(prm 'logand ;;; FIXME: bref
(prm 'srl ;;; FIXME: bref
(prm 'mref s
(prm 'int+
(prm 'sra i (K fixnum-shift))
(K (- disp-string-data string-tag))))
(K 255))
(prm 'sra i (K fixnum-shift));
;;; ENDIANNESS DEPENDENCY
(K (- disp-string-data
(- wordsize 1)
string-tag))))
(K (* (- wordsize 1) 8)))
(K char-shift))
(K char-tag)))])))]
[($make-string)
@ -1418,6 +1531,113 @@
(prm 'logor (Value (car arg*)) (Value (cadr arg*)))]
[($fxlognot)
(Value (prm '$fxlogxor (car arg*) (K -1)))]
[(+)
(let ()
(define (handle-binary a b)
(record-case a
[(constant i)
(if (fixnum? i)
(tbind ([b (Value b)])
(make-shortcut^
(tag-test b fixnum-mask fixnum-tag)
(prm 'int+/overflow (Value a) b)
(make-funcall (Value (make-primref '+))
(list (Value a) b))))
(make-funcall (Value (make-primref '+))
(list (Value a) b)))]
[else
(record-case b
[(constant i)
(if (fixnum? i)
(tbind ([a (Value a)])
(make-shortcut^
(tag-test a fixnum-mask fixnum-tag)
(prm 'int+/overflow a (Value b))
(make-funcall (Value (make-primref '+))
(list a (Value b)))))
(make-funcall (Value (make-primref '+))
(list a (Value b))))]
[else
(tbind ([a (Value a)]
[b (Value b)])
(make-shortcut^
(tag-test (prm 'logor a b) fixnum-mask fixnum-tag)
(prm 'int+/overflow a b)
(make-funcall (Value (make-primref '+))
(list a b))))])]))
(cond
[(null? arg*) (K 0)]
[(ormap (lambda (x)
(record-case x
[(constant i) (not (number? i))]
[else #f])) arg*)
(make-funcall (Value (make-primref '+)) (map Value arg*))]
[(= (length arg*) 1) ;;; FIXME: do something better
(handle-binary (K 0) (car arg*))]
[(= (length arg*) 2)
(handle-binary (car arg*) (cadr arg*))]
[else
(remove-complex* arg*
(lambda (arg*)
(Value
(let f ([a (car arg*)] [d (cdr arg*)])
(cond
[(null? d) a]
[else (f (prm '+ a (car d)) (cdr d))])))))]))]
[(-)
(let ()
(define (handle-binary a b)
(record-case a
[(constant i)
(if (fixnum? i)
(tbind ([b (Value b)])
(make-shortcut^
(tag-test b fixnum-mask fixnum-tag)
(prm 'int-/overflow (Value a) b)
(make-funcall (Value (make-primref '-))
(list (Value a) b))))
(make-funcall (Value (make-primref '-))
(list (Value a) b)))]
[else
(record-case b
[(constant i)
(if (fixnum? i)
(tbind ([a (Value a)])
(make-shortcut^
(tag-test a fixnum-mask fixnum-tag)
(prm 'int-/overflow a (Value b))
(make-funcall (Value (make-primref '-))
(list a (Value b)))))
(make-funcall (Value (make-primref '-))
(list a (Value b))))]
[else
(tbind ([a (Value a)]
[b (Value b)])
(make-shortcut^
(tag-test (prm 'logor a b) fixnum-mask fixnum-tag)
(prm 'int-/overflow a b)
(make-funcall (Value (make-primref '-))
(list a b))))])]))
(cond
[(or (null? arg*)
(ormap
(lambda (x)
(record-case x
[(constant i) (not (number? i))]
[else #f])) arg*))
(make-funcall (Value (make-primref '-)) (map Value arg*))]
[(= (length arg*) 1)
(handle-binary (K 0) (car arg*))]
[(= (length arg*) 2)
(handle-binary (car arg*) (cadr arg*))]
[else
(remove-complex* arg*
(lambda (arg*)
(Value
(let f ([a (car arg*)] [d (cdr arg*)])
(cond
[(null? d) a]
[else (f (prm '- a (car d)) (cdr d))])))))]))]
[($char->fixnum)
(tbind ([x (Value (car arg*))])
(prm 'sra x
@ -1878,7 +2098,8 @@
(S* rands
(lambda (rands)
(make-set d (make-disp (car rands) (cadr rands)))))]
[(logand logxor logor int+ int- int*)
[(logand logxor logor int+ int- int*
int-/overflow int+/overflow)
(make-seq
(V d (car rands))
(S (cadr rands)
@ -1900,7 +2121,7 @@
(make-asm-instr 'cltd edx eax)
(make-asm-instr 'idiv edx (cadr rands))
(make-set d edx))))]
[(sll sra)
[(sll sra srl)
(let ([a (car rands)] [b (cadr rands)])
(cond
[(constant? b)
@ -1923,10 +2144,14 @@
(handle-nontail-call
(make-constant (make-foreign-label op))
rands d op)]
[(shortcut^ test body handler)
(make-shortcut^ (P test)
(V d body)
(V d handler))]
[else
(if (symbol? x)
(make-set d x)
(error who "invalid value ~s" x))]))
(error who "invalid value ~s" (unparse x)))]))
;;;
(define (assign* lhs* rhs* ac)
(cond
@ -1991,31 +2216,6 @@
[else (error who "invalid pred ~s" x)]))
;;;
(define (Tail env)
#;(define (handle-tail-call target rator rands)
(let ([cpt (unique-var 'rator)]
[rt* (map (lambda (x) (unique-var 't)) rands)])
(do-bind rt* rands
(do-bind (list cpt) (list rator)
(let ([args (cons cpt rt*)]
[locs (formals-locations (cons cpt rt*))])
(assign* (reverse locs)
(reverse args)
(make-seq
(make-set argc-register
(make-constant
(argc-convention (length rands))))
(cond
[target
(make-primcall 'direct-jump
(cons target
(list* argc-register
pcr esp apr
locs)))]
[else
(make-primcall 'indirect-jump
(list* argc-register
pcr esp apr
locs))]))))))))
(define (handle-tail-call target rator rands)
(let* ([args (cons rator rands)]
[locs (formals-locations args)]
@ -2036,7 +2236,10 @@
(list* argc-register
pcr esp apr
locs))]))])
(let f ([args args] [locs locs] [targs '()] [tlocs '()])
(let f ([args (reverse args)]
[locs (reverse locs)]
[targs '()]
[tlocs '()])
(cond
[(null? args) (assign* tlocs targs rest)]
[(constant? (car args))
@ -2087,6 +2290,8 @@
[(jmpcall label rator rands)
(handle-tail-call (make-code-loc label) rator rands)]
[(forcall) (VT x)]
[(shortcut^ test body handler)
(make-shortcut^ (P test) (Tail body) (Tail handler))]
[else (error who "invalid tail ~s" x)]))
Tail)
;;;
@ -2255,6 +2460,8 @@
(case op
[(nop) #f]
[else (error who "invalid effect ~s" (unparse x))])]
[(shortcut^ test body handler)
(or (P test) (E body) (E handler))]
[else (error who "invalid effect ~s" x)]))
(define (P x)
(record-case x
@ -2271,6 +2478,8 @@
[(conditional e0 e1 e2)
(or (P e0) (T e1) (T e2))]
[(primcall) #f]
[(shortcut^ test body handler)
(or (P test) (T body) (T handler))]
[else (error who "invalid tail ~s" x)]))
(T x))
;;;
@ -2518,7 +2727,45 @@
(values (add-var s vs) rs fs ns))]
[else (error who "invalid ns ~s" s)])]
[else (error who "invalid d ~s" d)])]
[(logand logor logxor sll sra int+ int- int*)
[(int-/overflow int+/overflow)
(let ([v (exception-live-set)])
(unless (vector? v)
(error who "unbound exception"))
(let ([vs (union-vars vs (vector-ref v 0))]
[rs (union-regs rs (vector-ref v 1))]
[fs (union-frms fs (vector-ref v 2))]
[ns (union-nfvs ns (vector-ref v 3))])
(cond
[(var? d)
(cond
[(not (mem-var? d vs))
(set-asm-instr-op! x 'nop)
(values vs rs fs ns)]
[else
(let ([vs (rem-var d vs)])
(mark-var/vars-conf! d vs)
(mark-var/frms-conf! d fs)
(mark-var/nfvs-conf! d ns)
(mark-var/regs-conf! d rs)
(R s (set-add d vs) rs fs ns))])]
[(reg? d)
(cond
[(not (mem-reg? d rs))
(values vs rs fs ns)]
[else
(let ([rs (rem-reg d rs)])
(mark-reg/vars-conf! d vs)
(R s vs (set-add d rs) fs ns))])]
[(nfv? d)
(cond
[(not (mem-nfv? d ns)) (error who "dead nfv")]
[else
(let ([ns (rem-nfv d ns)])
(mark-nfv/vars-conf! d vs)
(mark-nfv/frms-conf! d fs)
(R s vs rs fs (add-nfv d ns)))])]
[else (error who "invalid op d ~s" (unparse x))])))]
[(logand logor logxor sll sra srl int+ int- int*)
(cond
[(var? d)
(cond
@ -2570,6 +2817,19 @@
(case op
[(nop) (values vs rs fs ns)]
[else (error who "invalid effect op ~s" op)])]
[(shortcut^ pred body handler)
(let-values ([(vsh rsh fsh nsh) (E handler vs rs fs ns)])
(let-values ([(vsb rsb fsb nsb)
(parameterize ([exception-live-set
(vector vsh rsh fsh nsh)])
(E body vs rs fs ns))])
(P pred
vsb rsb fsb nsb
vsh rsh fsh nsh
(union-vars vsb vsh)
(union-regs rsb rsh)
(union-frms fsb fsh)
(union-nfvs nsb nsh))))]
[else (error who "invalid effect ~s" (unparse x))]))
(define (P x vst rst fst nst
vsf rsf fsf nsf
@ -2627,7 +2887,22 @@
(empty-frm-set)
(empty-nfv-set))]
[else (error who "invalid tail op ~s" x)])]
[(shortcut^ pred body handler)
(let-values ([(vsh rsh fsh nsh) (T handler)])
(let-values ([(vsb rsb fsb nsb)
(parameterize ([exception-live-set
(vector vsh rsh fsh nsh)])
(T body))])
(P pred
vsb rsb fsb nsb
vsh rsh fsh nsh
(union-vars vsb vsh)
(union-regs rsb rsh)
(union-frms fsb fsh)
(union-nfvs nsb nsh))))]
[else (error who "invalid tail ~s" x)]))
(define exception-live-set
(make-parameter #f))
(T x)
spill-set)
(define-syntax frm-loc
@ -2651,26 +2926,6 @@
;;;
(define (assign-locations! ls)
(for-each (lambda (x) (set-var-loc! x #t)) ls))
;(define (assign-locations! ls)
; (define (assign x)
; (unless (var? x) (error 'assign "not a var"))
; (when (var-loc x) (error 'assign "already assigned"))
; (let ([frms (var-frm-conf x)]
; [vars (var-var-conf x)])
; (let f ([i 1])
; (cond
; [(frame-conflict? i vars frms) (f (fxadd1 i))]
; [else
; (let ([fv (mkfvar i)])
; (set-var-loc! x fv)
; (for-each
; (lambda (var)
; (set-var-var-conf! var
; (rem-var x (var-var-conf var)))
; (set-var-frm-conf! var
; (add-frm fv (var-frm-conf var))))
; vars))]))))
; (for-each assign ls))
(define (rewrite x)
(define who 'rewrite)
(define (assign x)
@ -2720,7 +2975,6 @@
fv)])))
(or (assign-move x)
(assign-any)))
(define (NFE idx mask x)
(record-case x
[(seq e0 e1)
@ -2767,14 +3021,12 @@
(let ([d (R d)] [s (R s)])
(cond
[(eq? d s)
(printf "N")
(make-primcall 'nop '())]
[else
(when (and (fvar? d) (fvar? s))
(printf "Y"))
(make-asm-instr 'move d s)]))]
[(logand logor logxor int+ int- int* mset bset/c bset/h sll sra
cltd idiv)
[(logand logor logxor int+ int- int* mset bset/c bset/h
sll sra srl
cltd idiv int-/overflow int+/overflow)
(make-asm-instr op (R d) (R s))]
[(nop) (make-primcall 'nop '())]
[else (error who "invalid op ~s" op)])]
@ -2865,6 +3117,8 @@
(case op
[(nop) x]
[else (error who "invalid effect prim ~s" op)])]
[(shortcut^ test body handler)
(make-shortcut^ (P test) (E body) (E handler))]
[else (error who "invalid effect ~s" (unparse x))]))
(define (P x)
(record-case x
@ -2884,6 +3138,8 @@
[(conditional e0 e1 e2)
(make-conditional (P e0) (T e1) (T e2))]
[(primcall op args) x]
[(shortcut^ test body handler)
(make-shortcut^ (P test) (T body) (T handler))]
[else (error who "invalid tail ~s" (unparse x))]))
(T x))
;;;
@ -2960,7 +3216,20 @@
[else
(for-each (lambda (y) (add-edge! g d y)) s)
(union (R v) s)]))]
[(logand logxor int+ int- int* logor sll sra)
[(int-/overflow int+/overflow)
(unless (exception-live-set)
(error who "uninitialized live set"))
(let ([s (set-rem d (set-union s (exception-live-set)))])
(record-case d
[(nfv c i)
(if (list? c)
(set-nfv-conf! d (set-union c s))
(set-nfv-conf! d s))
(union (union (R v) (R d)) s)]
[else
(for-each (lambda (y) (add-edge! g d y)) s)
(union (union (R v) (R d)) s)]))]
[(logand logxor int+ int- int* logor sll sra srl)
(let ([s (set-rem d s)])
(record-case d
[(nfv c i)
@ -3008,7 +3277,12 @@
(case op
[(nop) s]
[else (error who "invalid effect primcall ~s" op)])]
[else (error who "invalid effect ~s" x)]))
[(shortcut^ test body handler)
(let ([s2 (E handler s)])
(let ([s1 (parameterize ([exception-live-set s2])
(E body s))])
(P test s1 s2 (set-union s1 s2))))]
[else (error who "invalid effect ~s" (unparse x))]))
(define (P x st sf su)
(record-case x
[(constant c) (if c st sf)]
@ -3019,7 +3293,7 @@
(P e0 s1 s2 (set-union s1 s2)))]
[(asm-instr op s0 s1)
(union (union (R s0) (R s1)) su)]
[else (error who "invalid pred ~s" x)]))
[else (error who "invalid pred ~s" (unparse x))]))
(define (T x)
(record-case x
[(conditional e0 e1 e2)
@ -3028,7 +3302,13 @@
[(primcall op rands)
(R* rands)]
[(seq e0 e1) (E e0 (T e1))]
[else (error who "invalid tail ~s" x)]))
[(shortcut^ test body handler)
(let ([s2 (T handler)])
(let ([s1 (parameterize ([exception-live-set s2])
(T body))])
(P test s1 s2 (set-union s1 s2))))]
[else (error who "invalid tail ~s" (unparse x))]))
(define exception-live-set (make-parameter #f))
(let ([s (T x)])
;(print-graph g)
g))
@ -3138,7 +3418,9 @@
[(primcall op rands)
(make-primcall op (map R rands))]
[(ntcall) x]
[else (error who "invalid effect ~s" x)]))
[(shortcut^ test body handler)
(make-shortcut^ (P test) (E body) (E handler))]
[else (error who "invalid effect ~s" (unparse x))]))
(define (P x)
(record-case x
[(constant) x]
@ -3147,14 +3429,16 @@
[(conditional e0 e1 e2)
(make-conditional (P e0) (P e1) (P e2))]
[(seq e0 e1) (make-seq (E e0) (P e1))]
[else (error who "invalid pred ~s" x)]))
[else (error who "invalid pred ~s" (unparse x))]))
(define (T x)
(record-case x
[(primcall op rands) x]
[(conditional e0 e1 e2)
(make-conditional (P e0) (T e1) (T e2))]
[(seq e0 e1) (make-seq (E e0) (T e1))]
[else (error who "invalid tail ~s" x)]))
[(shortcut^ test body handler)
(make-shortcut^ (P test) (T body) (T handler))]
[else (error who "invalid tail ~s" (unparse x))]))
;(print-code x)
(T x))
;;;
@ -3210,8 +3494,11 @@
(make-conditional (P e0) (E e1) (E e2))]
[(asm-instr op a b)
(case op
[(logor logxor logand int+ int- int* move)
[(logor logxor logand int+ int- int* move
int-/overflow int+/overflow)
(cond
[(and (eq? op 'move) (eq? a b))
(make-primcall 'nop '())]
[(and (mem? a) (mem? b))
(let ([u (mku)])
(make-seq
@ -3257,7 +3544,7 @@
[(disp? b)
(error who "invalid arg to idiv ~s" b)]
[else x])]
[(sll sra)
[(sll sra srl)
(unless (or (constant? b)
(eq? b ecx))
(error who "invalid shift ~s" b))
@ -3300,9 +3587,12 @@
(S* rands
(lambda (s*)
(make-primcall op s*)))]
[else (error who "invalid op in ~s" x)])]
[else (error who "invalid op in ~s" (unparse x))])]
[(ntcall) x]
[else (error who "invalid effect ~s" x)]))
[(shortcut^ test body handler)
(let ([body (E body)])
(make-shortcut^ (P test) body (E handler)))]
[else (error who "invalid effect ~s" (unparse x))]))
(define (P x)
(record-case x
[(constant) x]
@ -3326,14 +3616,16 @@
(E (make-asm-instr 'move u b))
(make-asm-instr op a u)))]
[else x])]
[else (error who "invalid pred ~s" x)]))
[else (error who "invalid pred ~s" (unparse x))]))
(define (T x)
(record-case x
[(primcall op rands) x]
[(conditional e0 e1 e2)
(make-conditional (P e0) (T e1) (T e2))]
[(seq e0 e1) (make-seq (E e0) (T e1))]
[else (error who "invalid tail ~s" x)]))
[(shortcut^ test body handler)
(make-shortcut^ (P test) (T body) (T handler))]
[else (error who "invalid tail ~s" (unparse x))]))
(let ([x (T x)])
(values un* x)))
;;;
@ -3498,13 +3790,29 @@
[(logor) (cons `(orl ,(R s) ,(R d)) ac)]
[(logxor) (cons `(xorl ,(R s) ,(R d)) ac)]
[(mset) (cons `(movl ,(R s) ,(R d)) ac)]
[(move) (cons `(movl ,(R s) ,(R d)) ac)]
[(move)
(if (eq? d s)
ac
(cons `(movl ,(R s) ,(R d)) ac))]
[(bset/c) (cons `(movb ,(BYTE s) ,(R d)) ac)]
[(bset/h) (cons `(movb ,(reg/h s) ,(R d)) ac)]
[(sll) (cons `(sall ,(R/cl s) ,(R d)) ac)]
[(sra) (cons `(sarl ,(R/cl s) ,(R d)) ac)]
[(srl) (cons `(shrl ,(R/cl s) ,(R d)) ac)]
[(idiv) (cons `(idivl ,(R s)) ac)]
[(cltd) (cons `(cltd) ac)]
[(int-/overflow)
(let ([L (or (exception-label)
(error who "no exception label"))])
(list* `(subl ,(R s) ,(R d))
`(jo ,L)
ac))]
[(int+/overflow)
(let ([L (or (exception-label)
(error who "no exception label"))])
(list* `(addl ,(R s) ,(R d))
`(jo ,L)
ac))]
[else (error who "invalid instr ~s" x)])]
[(primcall op rands)
(case op
@ -3518,8 +3826,14 @@
`(addl ,(pcb-ref 'dirty-vector) ,a)
`(movl ,dirty-word (disp 0 ,a))
ac))]
[else (error who "invalid effect ~s" x)])]
[else (error who "invalid effect ~s" x)]))
[else (error who "invalid effect ~s" (unparse x))])]
[(shortcut^ test body handler)
(let ([L (unique-label)] [L2 (unique-label)])
(let ([ac (cons L (E handler (cons L2 ac)))])
(let ([ac (parameterize ([exception-label L])
(E body (cons `(jmp ,L2) ac)))])
(P test #f L ac))))]
[else (error who "invalid effect ~s" (unparse x))]))
;;;
(define (unique-label)
(label (gensym)))
@ -3612,7 +3926,14 @@
[(direct-jump)
(cons `(jmp (label ,(code-loc-label (car rands)))) ac)]
[else (error who "invalid tail ~s" x)])]
[(shortcut^ test body handler)
(let ([L (unique-label)])
(let ([ac (cons L (T handler ac))])
(let ([ac (parameterize ([exception-label L])
(T body ac))])
(P test #f L ac))))]
[else (error who "invalid tail ~s" x)]))
(define exception-label (make-parameter #f))
;;;
(define (handle-vararg fml-count ac)
(define CONTINUE_LABEL (unique-label))

7
src/libcompile.ss
View File

@ -256,6 +256,9 @@
(define-record shortcut^ (test body handler))
(define-record shortcut (body handler))
(define-record fvar (idx))
(define-record object (val))
(define-record locals (vars body))
@ -480,6 +483,10 @@
[(nframe vars live body) `(nframe ;[vars: ,(map E vars)]
;[live: ,(map E live)]
,(E body))]
[(shortcut^ pred body handler)
`(shortcut ,(E pred) ,(E body) ,(E handler))]
[(shortcut body handler)
`(exceptional ,(E body) ,(E handler))]
[else
(if (symbol? x)
x

10
src/libintelasm.ss
View File

@ -564,6 +564,8 @@
(CODE #xC1 (ModRM 3 '/5 dst (IMM8 src ac)))]
[(and (eq? src '%cl) (reg? dst))
(CODE #xD3 (ModRM 3 '/5 dst ac))]
[(and (imm8? src) (mem? dst))
((CODE/digit #xC1 '/5) dst (IMM8 src ac))]
[else (error who "invalid ~s" instr)])]
[(sarl src dst)
(cond
@ -873,7 +875,7 @@
(case (car x)
[(reloc-word foreign-label) (fx+ ac 2)]
[(relative reloc-word+ label-addr) (fx+ ac 3)]
[(word byte label current-frame-offset local-relative) ac]
[(word byte label current-frame-offset local-relative) ac]
[else (error 'compute-reloc-size "unknown instr ~s" x)])))
0
ls)))
@ -937,6 +939,9 @@
[(relative)
(let ([loc (label-loc v)])
(let ([obj (car loc)] [disp (cadr loc)])
(unless (and (code? obj) (fixnum? disp))
(error 'whack-reloc "invalid relative jump obj=~s disp=~s\n"
obj disp))
(vector-set! vec reloc-idx (fxlogor 3 (fxsll idx 2)))
(vector-set! vec (fx+ reloc-idx 1) (fx+ disp 11))
(vector-set! vec (fx+ reloc-idx 2) obj)))
@ -971,6 +976,9 @@
(lambda (foo reloc*)
(for-each (whack-reloc thunk?-label (car foo) (cdr foo)) reloc*))
(map cons code* relv*) reloc**)
;(for-each (lambda (x)
; (printf "RV=~s\n" x))
; relv*)
(for-each set-code-reloc-vector! code* relv*)
code*)))))))

8
src/makefile.ss
View File

@ -232,7 +232,6 @@
["libcontrol1.ss" "libcontrol1.fasl" p0 onepass]
["libcollect.ss" "libcollect.fasl" p0 onepass]
["librecord.ss" "librecord.fasl" p0 onepass]
;["libcxr.ss" "libcxr.fasl" p0 chaitin]
["libcxr.ss" "libcxr.fasl" p0 onepass]
["libnumerics.ss" "libnumerics.fasl" p0 onepass]
["libguardians.ss" "libguardians.fasl" p0 onepass]
@ -282,7 +281,7 @@
(let ()
#;(let ()
(define (compile-all who)
(for-each
(lambda (x)
@ -299,10 +298,9 @@
(time (compile-all 'p0))
(exit))))
#;(for-each
(for-each
(lambda (x)
(when (cadr x)
(compile-library (car x) (cadr x))))
(compile-library (car x) (cadr x) (cadddr x)))
scheme-library-files)
(define (join s ls)