st/lama_byterun
1
0
Fork 0
mirror of https://github.com/ProgramSnail/Lama.git synced 2025-12-05 22:38:44 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

Merge branch 'hw15'

Browse source
This commit is contained in:
Dmitry Boulytchev 2019-03-07 14:44:34 +03:00
commit f14bbf8fcb
11 changed files with 2259 additions and 83 deletions
Download patch file Download diff file Expand all files Collapse all files

5
regression/Makefile
View file

@ -12,4 +12,7 @@ $(TESTS): %: %.expr
@cat $@.input | $(RC) -s $< > $@.log && diff $@.log orig/$@.log
clean:
rm -f test*.log *.s *~ $(TESTS)
$(RM) test*.log *.s *~ $(TESTS)
$(MAKE) clean -C expressions
$(MAKE) clean -C deep-expressions
$(MAKE) clean -C x86only

3
regression/deep-expressions/Makefile
View file

@ -12,4 +12,5 @@ $(TESTS): %: %.expr
@cat $@.input | $(RC) -s $< > $@.log && diff $@.log orig/$@.log
clean:
rm -f *.log *.s *~ $(TESTS)
rm -f *.log *.s *~
find . -maxdepth 1 -type f -not -name '*.*' -not -name 'Makefile' -delete

4
regression/expressions/Makefile
View file

@ -12,4 +12,6 @@ $(TESTS): %: %.expr
@cat $@.input | $(RC) -s $< > $@.log && diff $@.log orig/$@.log
clean:
rm -f *.log *.s *~ $(TESTS)
rm -f *.log *.s *~
find . -maxdepth 1 -type f -not -name '*.*' -not -name 'Makefile' -delete

1
regression/test039.expr
View file

@ -28,4 +28,3 @@ write (find (t, 6));
write (find (t, 3));
write (find (t, 2));
write (find (t, 1))

12
runtime/Makefile
View file

@ -1,6 +1,12 @@
all:
gcc -m32 -c runtime.c
all: gc_runtime.o runtime.o
ar rc runtime.a gc_runtime.o runtime.o
gc_runtime.o: gc_runtime.s
gcc -g -fstack-protector-all -m32 -c gc_runtime.s
runtime.o: runtime.c
gcc -g -fstack-protector-all -m32 -c runtime.c
clean:
rm -f runtime.o *~
rm -f *.a *.o *~

114
runtime/gc_runtime.s Normal file
View file

@ -0,0 +1,114 @@
.data
printf_format: .string "Stack root: %lx\n"
printf_format2: .string "BOT: %lx\n"
printf_format3: .string "TOP: %lx\n"
printf_format4: .string "EAX: %lx\n"
printf_format5: .string "LOL\n"
__gc_stack_bottom: .long 0
__gc_stack_top: .long 0
.globl __pre_gc
.globl __post_gc
.globl L__gc_init
.globl __gc_root_scan_stack
.extern init_pool
.extern gc_test_and_copy_root
.text
L__gc_init: movl %esp, __gc_stack_bottom
addl $4, __gc_stack_bottom
call init_pool
ret
// if __gc_stack_top is equal to 0
// then set __gc_stack_top to %ebp
// else return
__pre_gc:
pushl %eax
movl __gc_stack_top, %eax
cmpl $0, %eax
jne __pre_gc_2
movl %ebp, %eax
// addl $8, %eax
movl %eax, __gc_stack_top
__pre_gc_2:
popl %eax
ret
// if __gc_stack_top has been set by the caller
// (i.e. it is equal to its %ebp)
// then set __gc_stack_top to 0
// else return
__post_gc:
pushl %eax
movl __gc_stack_top, %eax
cmpl %eax, %ebp
jnz __post_gc2
movl $0, __gc_stack_top
__post_gc2:
popl %eax
ret
// Scan stack for roots
// strting from __gc_stack_top
// till __gc_stack_bottom
__gc_root_scan_stack:
pushl %ebp
movl %esp, %ebp
pushl %ebx
pushl %edx
movl __gc_stack_top, %eax
jmp next
loop:
movl (%eax), %ebx
// check that it is not a pointer to code section
// i.e. the following is not true:
// __executable_start <= (%eax) <= __etext
check11:
leal __executable_start, %edx
cmpl %ebx, %edx
jna check12
jmp check21
check12:
leal __etext, %edx
cmpl %ebx, %edx
jnb next
// check that it is not a pointer into the program stack
// i.e. the following is not true:
// __gc_stack_bottom <= (%eax) <= __gc_stack_top
check21:
cmpl %ebx, __gc_stack_top
jna check22
jmp loop2
check22:
cmpl %ebx, __gc_stack_bottom
jnb next
// check if it a valid pointer
// i.e. the lastest bit is set to zero
loop2:
andl $0x00000001, %ebx
jnz next
gc_run_t:
pushl %eax
pushl %eax
call gc_test_and_copy_root
addl $4, %esp
popl %eax
next:
addl $4, %eax
cmpl %eax, __gc_stack_bottom
jne loop
returnn:
movl $0, %eax
popl %edx
popl %ebx
movl %ebp, %esp
popl %ebp
ret

457
runtime/runtime.c
View file

@ -2,18 +2,20 @@
# include <stdio.h>
# include <stdio.h>
# include <malloc.h>
# include <string.h>
# include <stdarg.h>
# include <alloca.h>
# include <stdlib.h>
# include <sys/mman.h>
# include <assert.h>
# define STRING_TAG 0x00000000
# define ARRAY_TAG 0x01000000
# define SEXP_TAG 0x02000000
// # define DEBUG_PRINT 1
# define LEN(x) (x & 0x00FFFFFF)
# define TAG(x) (x & 0xFF000000)
# define STRING_TAG 0x00000001
# define ARRAY_TAG 0x00000003
# define SEXP_TAG 0x00000005
# define LEN(x) ((x & 0xFFFFFFF8) >> 3)
# define TAG(x) (x & 0x00000007)
# define TO_DATA(x) ((data*)((char*)(x)-sizeof(int)))
# define TO_SEXP(x) ((sexp*)((char*)(x)-2*sizeof(int)))
@ -32,22 +34,31 @@ typedef struct {
data contents;
} sexp;
extern void* alloc (size_t);
extern int Blength (void *p) {
data *a = TO_DATA(p);
data *a = (char*) BOX (NULL);
a = TO_DATA(p);
return BOX(LEN(a->tag));
}
char* de_hash (int n) {
static char *chars = "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNJPQRSTUVWXYZ";
static char buf[6];
char *p = &buf[5];
static char *chars = (char*) BOX (NULL);
static char buf[6] = {0,0,0,0,0,0};
char *p = (char*) BOX (NULL);
chars = "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNJPQRSTUVWXYZ";
p = &buf[5];
/*printf ("tag: %d\n", n);*/
#ifdef DEBUG_PRINT
printf ("de_hash: tag: %d\n", n);
#endif
*p-- = 0;
while (n != 0) {
/*printf ("char: %c\n", chars [n & 0x003F]);*/
#ifdef DEBUG_PRINT
printf ("char: %c\n", chars [n & 0x003F]);
#endif
*p-- = chars [n & 0x003F];
n = n >> 6;
}
@ -83,9 +94,10 @@ static void extendStringBuf () {
}
static void printStringBuf (char *fmt, ...) {
va_list args;
int written, rest;
char *buf;
va_list args = (va_list) BOX(NULL);
int written = 0,
rest = 0;
char *buf = (char*) BOX(NULL);
again:
va_start (args, fmt);
@ -102,9 +114,11 @@ static void printStringBuf (char *fmt, ...) {
}
static void printValue (void *p) {
data *a = (data*) BOX(NULL);
int i = BOX(0);
if (UNBOXED(p)) printStringBuf ("%d", UNBOX(p));
else {
data *a = TO_DATA(p);
a = TO_DATA(p);
switch (TAG(a->tag)) {
case STRING_TAG:
@ -113,7 +127,7 @@ static void printValue (void *p) {
case ARRAY_TAG:
printStringBuf ("[");
for (int i = 0; i < LEN(a->tag); i++) {
for (i = 0; i < LEN(a->tag); i++) {
printValue ((void*)((int*) a->contents)[i]);
if (i != LEN(a->tag) - 1) printStringBuf (", ");
}
@ -124,7 +138,7 @@ static void printValue (void *p) {
printStringBuf ("`%s", de_hash (TO_SEXP(p)->tag));
if (LEN(a->tag)) {
printStringBuf (" (");
for (int i = 0; i < LEN(a->tag); i++) {
for (i = 0; i < LEN(a->tag); i++) {
printValue ((void*)((int*) a->contents)[i]);
if (i != LEN(a->tag) - 1) printStringBuf (", ");
}
@ -139,11 +153,10 @@ static void printValue (void *p) {
}
extern void* Belem (void *p, int i) {
data *a = TO_DATA(p);
data *a = (data *)BOX(NULL);
a = TO_DATA(p);
i = UNBOX(i);
/* printf ("elem %d = %p\n", i, (void*) ((int*) a->contents)[i]); */
if (TAG(a->tag) == STRING_TAG) {
return (void*) BOX(a->contents[i]);
}
@ -152,17 +165,26 @@ extern void* Belem (void *p, int i) {
}
extern void* Bstring (void *p) {
int n = strlen (p);
data *r = (data*) malloc (n + 1 + sizeof (int));
int n = BOX(0);
data *r = NULL;
r->tag = n;
__pre_gc () ;
n = strlen (p);
r = (data*) alloc (n + 1 + sizeof (int));
r->tag = STRING_TAG | (n << 3);
strncpy (r->contents, p, n + 1);
__post_gc();
return r->contents;
}
extern void* Bstringval (void *p) {
void *s;
void *s = BOX(NULL);
__pre_gc () ;
createStringBuf ();
printValue (p);
@ -171,70 +193,98 @@ extern void* Bstringval (void *p) {
deleteStringBuf ();
__post_gc ();
return s;
}
extern void* Barray (int n, ...) {
va_list args;
int i;
data *r = (data*) malloc (sizeof(int) * (n+1));
va_list args = (va_list) BOX (NULL);
int i = BOX(0),
ai = BOX(0);
data *r = (data*) BOX (NULL);
r->tag = ARRAY_TAG | n;
__pre_gc ();
#ifdef DEBUG_PRINT
printf ("Barray: create n = %d\n", n);
fflush(stdout);
#endif
r = (data*) alloc (sizeof(int) * (n+1));
r->tag = ARRAY_TAG | (n << 3);
va_start(args, n);
for (i=0; i<n; i++) {
int ai = va_arg(args, int);
for (i = 0; i<n; i++) {
ai = va_arg(args, int);
((int*)r->contents)[i] = ai;
}
va_end(args);
__post_gc();
return r->contents;
}
extern void* Bsexp (int n, ...) {
va_list args;
int i;
sexp *r = (sexp*) malloc (sizeof(int) * (n+2));
data *d = &(r->contents);
va_list args = (va_list) BOX (NULL);
int i = BOX(0);
int ai = BOX(0);
size_t * p = NULL;
sexp *r = (sexp*) BOX (NULL);
data *d = (sexp*) BOX (NULL);
d->tag = SEXP_TAG | (n-1);
__pre_gc () ;
#ifdef DEBUG_PRINT
printf("Bsexp: allocate %zu!\n",sizeof(int) * (n+1));
#endif
r = (sexp*) alloc (sizeof(int) * (n+1));
d = &(r->contents);
r->tag = 0;
d->tag = SEXP_TAG | ((n-1) << 3);
va_start(args, n);
for (i=0; i<n-1; i++) {
int ai = va_arg(args, int);
//printf ("arg %d = %x\n", i, ai);
((int*)d->contents)[i] = ai;
ai = va_arg(args, int);
p = (size_t*) ai;
((int*)d->contents)[i] = ai;
}
r->tag = va_arg(args, int);
va_end(args);
//printf ("tag %d\n", r->tag);
//printf ("returning %p\n", d->contents);
__post_gc();
return d->contents;
}
extern int Btag (void *d, int t, int n) {
data *r = TO_DATA(d);
data *r = (data*) BOX (NULL);
r = TO_DATA(d);
return BOX(TAG(r->tag) == SEXP_TAG && TO_SEXP(d)->tag == t && LEN(r->tag) == n);
}
extern int Barray_patt (void *d, int n) {
data *r = BOX(NULL);
if (UNBOXED(d)) return BOX(0);
else {
data *r = TO_DATA(d);
r = TO_DATA(d);
return BOX(TAG(r->tag) == ARRAY_TAG && LEN(r->tag) == n);
}
}
extern int Bstring_patt (void *x, void *y) {
data *rx = (data *) BOX (NULL),
*ry = (data *) BOX (NULL);
if (UNBOXED(x)) return BOX(0);
else {
data *rx = TO_DATA(x), *ry = TO_DATA(y);
rx = TO_DATA(x); ry = TO_DATA(y);
if (TAG(rx->tag) != STRING_TAG) return BOX(0);
@ -269,13 +319,13 @@ extern int Bsexp_tag_patt (void *x) {
}
extern void Bsta (int n, int v, void *s, ...) {
va_list args;
int i, k;
data *a;
va_list args = (va_list) BOX (NULL);
int i = 0, k = 0;
data *a = (data*) BOX (NULL);
va_start(args, s);
for (i=0; i<n-1; i++) {
for (i = 0; i < n-1; i++) {
k = UNBOX(va_arg(args, int));
s = ((int**) s) [k];
}
@ -292,7 +342,7 @@ extern int Lraw (int x) {
}
extern void Lprintf (char *s, ...) {
va_list args;
va_list args = (va_list) BOX (NULL);
va_start (args, s);
vprintf (s, args); // vprintf (char *, va_list) <-> printf (char *, ...)
@ -300,21 +350,29 @@ extern void Lprintf (char *s, ...) {
}
extern void* Lstrcat (void *a, void *b) {
data *da = TO_DATA(a);
data *db = TO_DATA(b);
data *da = (data*) BOX (NULL);
data *db = (data*) BOX (NULL);
data *d = (data*) BOX (NULL);
da = TO_DATA(a);
db = TO_DATA(b);
__pre_gc () ;
data *d = (data *) malloc (sizeof(int) + LEN(da->tag) + LEN(db->tag) + 1);
d = (data *) alloc (sizeof(int) + LEN(da->tag) + LEN(db->tag) + 1);
d->tag = LEN(da->tag) + LEN(db->tag);
strcpy (d->contents, da->contents);
strcat (d->contents, db->contents);
__post_gc();
return d->contents;
}
extern void Lfprintf (FILE *f, char *s, ...) {
va_list args;
va_list args = (va_list) BOX (NULL);
va_start (args, s);
vfprintf (f, s, args);
@ -331,7 +389,7 @@ extern void Lfclose (FILE *f) {
/* Lread is an implementation of the "read" construct */
extern int Lread () {
int result;
int result = BOX(0);
printf ("> ");
fflush (stdout);
@ -348,3 +406,290 @@ extern int Lwrite (int n) {
return 0;
}
/* GC starts here */
extern const size_t __gc_data_end, __gc_data_start;
extern void L__gc_init ();
extern void __pre_gc ();
extern void __post_gc ();
extern void __gc_root_scan_stack ();
/* ======================================== */
/* Mark-and-copy */
/* ======================================== */
static size_t SPACE_SIZE = 128;
# define POOL_SIZE (2*SPACE_SIZE)
typedef struct {
size_t * begin;
size_t * end;
size_t * current;
size_t size;
} pool;
static pool from_space;
static pool to_space;
size_t * current;
static void swap (size_t ** a, size_t ** b) {
size_t * t = *a;
*a = *b;
*b = t;
}
static void gc_swap_spaces (void) {
swap (&from_space.begin, &to_space.begin);
swap (&from_space.end , &to_space.end );
from_space.current = current;
to_space.current = to_space.begin;
}
# define IS_VALID_HEAP_POINTER(p)\
(!UNBOXED(p) && \
from_space.begin <= p && \
from_space.end > p)
# define IN_PASSIVE_SPACE(p) \
(to_space.begin <= p && \
to_space.end > p)
# define IS_FORWARD_PTR(p) \
(!UNBOXED(p) && IN_PASSIVE_SPACE(p))
extern size_t * gc_copy (size_t *obj);
static void copy_elements (size_t *where, size_t *from, int len) {
int i = 0;
void * p = NULL;
for (i = 0; i < len; i++) {
size_t elem = from[i];
if (!IS_VALID_HEAP_POINTER(elem)) {
*where = elem;
where++;
}
else {
p = gc_copy ((size_t*) elem);
*where = p;
#ifdef DEBUG_PRINT
printf ("copy_elements: fix %x: %x\n", from, *where);
#endif
where ++;
}
}
}
static void extend_spaces (void) {
void *p1 = mremap(from_space.begin, SPACE_SIZE, 2*SPACE_SIZE, 0);
void *p2 = mremap(to_space.begin , SPACE_SIZE, 2*SPACE_SIZE, 0);
if (p1 == MAP_FAILED || p2 == MAP_FAILED) {
perror("EROOR: extend_spaces: mmap failed\n");
exit (1);
}
#ifdef DEBUG_PRINT
printf ("extend: %x %x %x %x\n", p1, p2, from_space.begin, to_space.begin);
printf ("extend: %x %x %x\n", from_space.end, to_space.end, current);
#endif
from_space.end += SPACE_SIZE;
to_space.end += SPACE_SIZE;
SPACE_SIZE += SPACE_SIZE;
from_space.size = SPACE_SIZE;
to_space.size = SPACE_SIZE;
}
extern size_t * gc_copy (size_t *obj) {
data *d = TO_DATA(obj);
sexp *s = NULL;
size_t *copy = NULL;
int i = 0;
#ifdef DEBUG_PRINT
int len1, len2, len3;
void * objj;
void * newobjj = (void*)current;
printf("gc_copy: %x cur = %x starts\n", obj, current);
#endif
if (!IS_VALID_HEAP_POINTER(obj)) {
#ifdef DEBUG_PRINT
printf ("gc_copy: invalid ptr: %x\n", obj);
#endif
return obj;
}
if (!IN_PASSIVE_SPACE(current) && current != to_space.end) {
#ifdef DEBUG_PRINT
printf("ERROR: gc_copy: out-of-space %x %x %x\n", current, to_space.begin, to_space.end);
fflush(stdout);
#endif
perror("ERROR: gc_copy: out-of-space\n");
exit (1);
}
if (IS_FORWARD_PTR(d->tag)) {
#ifdef DEBUG_PRINT
printf ("gc_copy: IS_FORWARD_PTR: return! %x\n", (size_t *) d->tag);
fflush(stdout);
#endif
return (size_t *) d->tag;
}
copy = current;
#ifdef DEBUG_PRINT
objj = d;
#endif
switch (TAG(d->tag)) {
case ARRAY_TAG:
#ifdef DEBUG_PRINT
printf ("gc_copy:array_tag; len = %zu\n", LEN(d->tag));
fflush(stdout);
#endif
current += (LEN(d->tag) + 1) * sizeof (int);
*copy = d->tag;
copy++;
i = LEN(d->tag);
d->tag = (int) copy;
copy_elements (copy, obj, i);
break;
case STRING_TAG:
#ifdef DEBUG_PRINT
printf ("gc_copy:string_tag; len = %d\n", LEN(d->tag) + 1);
fflush(stdout);
#endif
current += LEN(d->tag) * sizeof(char) + sizeof (int);
*copy = d->tag;
copy++;
d->tag = (int) copy;
strcpy (&copy[0], (char*) obj);
break;
case SEXP_TAG :
s = TO_SEXP(obj);
#ifdef DEBUG_PRINT
objj = s;
len1 = LEN(s->contents.tag);
len2 = LEN(s->tag);
len3 = LEN(d->tag);
printf("len1 = %li, len2=%li, len3 = %li\n",len1,len2,len3);
#endif
current += (LEN(s->contents.tag) + 2) * sizeof (int);
*copy = s->tag;
copy++;
*copy = s->contents.tag;
copy++;
i = LEN(s->contents.tag);
d->tag = (int) copy;
copy_elements (copy, obj, i);
break;
default:
#ifdef DEBUG_PRINT
printf ("ERROR: gc_copy: weird tag: %x", TAG(d->tag));
fflush(stdout);
#endif
perror ("ERROR: gc_copy: weird tag");
exit (1);
}
#ifdef DEBUG_PRINT
printf("gc_copy: %x (%x) -> %x (%x); new-current = %x\n", obj, objj, copy, newobjj, current);
fflush(stdout);
#endif
return copy;
}
extern void gc_test_and_copy_root (size_t ** root) {
if (IS_VALID_HEAP_POINTER(*root)) {
#ifdef DEBUG_PRINT
printf ("gc_test_and_copy_root: root %x %x\n", root, *root);
#endif
*root = gc_copy (*root);
}
}
extern void gc_root_scan_data (void) {
size_t * p = &__gc_data_start;
while (p != &__gc_data_end) {
gc_test_and_copy_root (p);
p++;
}
}
extern void init_pool (void) {
from_space.begin = mmap(NULL, SPACE_SIZE, PROT_READ | PROT_WRITE,
MAP_PRIVATE | MAP_ANONYMOUS | MAP_32BIT, -1, 0);
to_space.begin = mmap(NULL, SPACE_SIZE, PROT_READ | PROT_WRITE,
MAP_PRIVATE | MAP_ANONYMOUS | MAP_32BIT, -1, 0);
if (to_space.begin == MAP_FAILED ||
from_space.begin == MAP_FAILED) {
perror("EROOR: init_pool: mmap failed\n");
exit (1);
}
from_space.current = from_space.begin;
from_space.end = from_space.begin + SPACE_SIZE;
from_space.size = SPACE_SIZE;
to_space.current = to_space.begin;
to_space.end = to_space.begin + SPACE_SIZE;
to_space.size = SPACE_SIZE;
}
static int free_pool (pool * p) {
return munmap((void *)p->begin, p->size);
}
static void * gc (size_t size) {
current = to_space.begin;
#ifdef DEBUG_PRINT
printf("\ngc: current: %x; to_space.b = %x; to_space.e = %x; f_space.b = %x; f_space.e = %x\n",
current, to_space.begin, to_space.end, from_space.begin, from_space.end);
#endif
gc_root_scan_data ();
#ifdef DEBUG_PRINT
printf("gc: data is scanned\n");
#endif
__gc_root_scan_stack ();
if (!IN_PASSIVE_SPACE(current)) {
perror ("ASSERT: !IN_PASSIVE_SPACE(current)\n");
exit (1);
}
while (current + size >= to_space.end) {
#ifdef DEBUG_PRINT
printf ("gc pre-extend_spaces : %x %x %x \n", current, size, to_space.end);
#endif
extend_spaces ();
#ifdef DEBUG_PRINT
printf ("gc post-extend_spaces: %x %x %x \n", current, size, to_space.end);
#endif
}
assert (IN_PASSIVE_SPACE(current));
assert (current + size < to_space.end);
gc_swap_spaces ();
from_space.current = current + size;
#ifdef DEBUG_PRINT
printf ("gc: end: (allocate!) return %x; from_space.current %x; from_space.end \n\n",
current, from_space.current, from_space.end);
#endif
return (void *) current;
}
extern void * alloc (size_t size) {
void * p = (void*)BOX(NULL);
if (from_space.current + size < from_space.end) {
#ifdef DEBUG_PRINT
printf("alloc: current: %x %zu", from_space.current, size);
#endif
p = (void*) from_space.current;
from_space.current += size;
#ifdef DEBUG_PRINT
printf(";new current: %x \n", from_space.current);
#endif
return p;
}
#ifdef DEBUG_PRINT
printf("alloc: call gc: %zu\n", size);
#endif
return gc (size);
}

1640
runtime/runtime.s Normal file
View file

File diff suppressed because it is too large Load diff

9
runtime/testgc.expr Normal file
View file

@ -0,0 +1,9 @@
fun print_list (l) {
case l of
`nil -> skip
| `cons (n, t) -> write (n); print_list (t)
esac
}
x := `cons (4, `cons(3, `cons(2 , `cons (1, `cons (0, `cons (1, `cons (2, `cons (3, `cons (4, `cons (5, `nil))))))))));
print_list (x)

75
src/X86.ml
View file

@ -19,6 +19,8 @@ let word_size = 4;;
| L of int (* an immediate operand *)
with show
let show_opnd = show(opnd)
(* For convenience we define the following synonyms for the registers: *)
let ebx = R 0
let ecx = R 1
@ -52,6 +54,7 @@ type instr =
(* arithmetic correction: or 0x0001 *) | Or1 of opnd
(* arithmetic correction: shl 1 *) | Sal1 of opnd
(* arithmetic correction: shr 1 *) | Sar1 of opnd
| Repmovsl
(* Instruction printer *)
let show instr =
@ -91,6 +94,7 @@ let show instr =
| Or1 s -> Printf.sprintf "\torl\t$0x0001,\t%s" (opnd s)
| Sal1 s -> Printf.sprintf "\tsall\t%s" (opnd s)
| Sar1 s -> Printf.sprintf "\tsarl\t%s" (opnd s)
| Repmovsl -> Printf.sprintf "\trep movsl\t"
(* Opening stack machine to use instructions without fully qualified names *)
open SM
@ -164,7 +168,7 @@ let compile env code =
(env, Mov (M ("$" ^ s), l) :: call)
| LD x ->
let s, env' = (env#global x)#allocate in
let s, env' = (env#variable x)#allocate in
env',
(match s with
| S _ | M _ -> [Mov (env'#loc x, eax); Mov (eax, s)]
@ -172,7 +176,7 @@ let compile env code =
)
| STA (x, n) ->
let s, env = (env#global x)#allocate in
let s, env = (env#variable x)#allocate in
let push =
match s with
| S _ | M _ -> [Mov (env#loc x, eax); Mov (eax, s)]
@ -182,7 +186,7 @@ let compile env code =
env, push @ code
| ST x ->
let s, env' = (env#global x)#pop in
let s, env' = (env#variable x)#pop in
env',
(match s with
| S _ | M _ -> [Mov (s, eax); Mov (eax, env'#loc x)]
@ -288,14 +292,20 @@ let compile env code =
| BEGIN (f, a, l) ->
let env = env#enter f a l in
env, [Push ebp; Mov (esp, ebp); Binop ("-", M ("$" ^ env#lsize), esp)]
env, [Push ebp; Mov (esp, ebp); Binop ("-", M ("$" ^ env#lsize), esp);
Mov (esp, edi);
Mov (M "$filler", esi);
Mov (M ("$" ^ (env#allocated_size)), ecx);
Repmovsl
]
| END ->
env, [Label env#epilogue;
env#endfunc, [Label env#epilogue;
Mov (ebp, esp);
Pop ebp;
Ret;
Meta (Printf.sprintf "\t.set\t%s,\t%d" env#lsize (env#allocated * word_size))
Meta (Printf.sprintf "\t.set\t%s,\t%d" env#lsize (env#allocated * word_size));
Meta (Printf.sprintf "\t.set\t%s,\t%d" env#allocated_size env#allocated)
]
| RET b ->
@ -386,6 +396,14 @@ class env =
val fname = "" (* function name *)
val stackmap = M.empty (* labels to stack map *)
val barrier = false (* barrier condition *)
val max_locals_size = 0
method max_locals_size = max_locals_size
method endfunc =
if stack_slots > max_locals_size
then {< max_locals_size = stack_slots >}
else self
method show_stack =
GT.show(list) (GT.show(opnd)) stack
@ -425,13 +443,13 @@ class env =
(* allocates a fresh position on a symbolic stack *)
method allocate =
let x, n =
let rec allocate' = function
| [] -> ebx , 0
| (S n)::_ -> S (n+1) , n+2
| (R n)::_ when n < num_of_regs -> R (n+1) , stack_slots
| _ -> S static_size, static_size+1
in
allocate' stack
let rec allocate' = function
| [] -> ebx , 0
| (S n)::_ -> S (n+1) , n+2
| (R n)::_ when n < num_of_regs -> R (n+1) , stack_slots
| _ -> S static_size, static_size+1
in
allocate' stack
in
x, {< stack_slots = max n stack_slots; stack = x::stack >}
@ -458,8 +476,11 @@ class env =
done;
!h
(* registers a global variable in the environment *)
method global x = {< globals = S.add ("global_" ^ x) globals >}
(* registers a variable in the environment *)
method variable x =
match self#loc x with
| M name -> {< globals = S.add name globals >}
| _ -> self
(* registers a string constant *)
method string x =
@ -476,7 +497,9 @@ class env =
method strings = M.bindings stringm
(* gets a number of stack positions allocated *)
method allocated = stack_slots
method allocated = stack_slots
method allocated_size = Printf.sprintf "LS%s_SIZE" fname
(* enters a function *)
method enter f a l =
@ -515,14 +538,26 @@ class env =
the stack code, then generates x86 assember code, then prints the assembler file
*)
let genasm (ds, stmt) =
let stmt = Language.Stmt.Seq (stmt, Language.Stmt.Return (Some (Language.Expr.Call ("raw", [Language.Expr.Const 0])))) in
let stmt =
Language.Stmt.Seq (
Language.Stmt.Call ("__gc_init", []),
Language.Stmt.Seq (stmt, Language.Stmt.Return (Some (Language.Expr.Call ("raw", [Language.Expr.Const 0]))))
)
in
let env, code =
compile
(new env)
((LABEL "main") :: (BEGIN ("main", [], [])) :: SM.compile (ds, stmt))
in
let data = Meta "\t.data" :: (List.map (fun s -> Meta (Printf.sprintf "%s:\t.int\t0" s )) env#globals) @
(List.map (fun (s, v) -> Meta (Printf.sprintf "%s:\t.string\t\"%s\"" v s)) env#strings) in
let gc_start, gc_end = "__gc_data_start", "__gc_data_end" in
let data = [Meta "\t.data";
Meta (Printf.sprintf "filler:\t.fill\t%d, 4, 1" env#max_locals_size);
Meta (Printf.sprintf "\t.globl\t%s" gc_start); Meta (Printf.sprintf "\t.globl\t%s" gc_end)] @
[Meta (Printf.sprintf "%s:" gc_start)] @
(List.map (fun s -> Meta (Printf.sprintf "%s:\t.int\t1" s )) env#globals) @
[Meta (Printf.sprintf "%s:" gc_end)] @
(List.map (fun (s, v) -> Meta (Printf.sprintf "%s:\t.string\t\"%s\"" v s)) env#strings)
in
let asm = Buffer.create 1024 in
List.iter
(fun i -> Buffer.add_string asm (Printf.sprintf "%s\n" @@ show i))
@ -535,5 +570,5 @@ let build prog name =
Printf.fprintf outf "%s" (genasm prog);
close_out outf;
let inc = try Sys.getenv "RC_RUNTIME" with _ -> "../runtime" in
Sys.command (Printf.sprintf "gcc -m32 -o %s %s/runtime.o %s.s" name inc name)
Sys.command (Printf.sprintf "gcc -g -m32 -o %s %s/gc_runtime.o %s/runtime.o %s.s" name inc inc name)

22
src/testgc.expr Normal file
View file

@ -0,0 +1,22 @@
fun f () local b {
b := 7;
test ();
b := y;
test ();
b := 9;
test ();
return 0
}
--x := 0;
--y := 0;
--z := 0;
--t := 0;
--test ();
y := "abc";
test ();
t := [];
test ();
t := 0;
test ();
f ()