From f51d063e526b44edf7e2f9fe2450ac2705f9593b Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Wed, 28 Aug 2024 20:49:37 +0300 Subject: [PATCH] Made x32 copy --- runtime32/.gitignore | 2 + runtime32/Makefile | 12 + runtime32/Std.i | 59 ++ runtime32/gc_runtime.s | 116 +++ runtime32/gr.dot | 2 + runtime32/runtime.c | 2102 ++++++++++++++++++++++++++++++++++++++++ runtime32/runtime.h | 21 + src/X32.ml | 848 ++++++++++++++++ 8 files changed, 3162 insertions(+) create mode 100644 runtime32/.gitignore create mode 100644 runtime32/Makefile create mode 100644 runtime32/Std.i create mode 100644 runtime32/gc_runtime.s create mode 100644 runtime32/gr.dot create mode 100644 runtime32/runtime.c create mode 100644 runtime32/runtime.h create mode 100644 src/X32.ml diff --git a/runtime32/.gitignore b/runtime32/.gitignore new file mode 100644 index 000000000..ede012c6b --- /dev/null +++ b/runtime32/.gitignore @@ -0,0 +1,2 @@ +*.a + diff --git a/runtime32/Makefile b/runtime32/Makefile new file mode 100644 index 000000000..a82daa3f0 --- /dev/null +++ b/runtime32/Makefile @@ -0,0 +1,12 @@ + +all: gc_runtime.o runtime.o + ar rc runtime.a gc_runtime.o runtime.o + +gc_runtime.o: gc_runtime.s + $(CC) -g -fstack-protector-all -m32 -c gc_runtime.s + +runtime.o: runtime.c runtime.h + $(CC) -g -fstack-protector-all -m32 -c runtime.c + +clean: + $(RM) *.a *.o *~ diff --git a/runtime32/Std.i b/runtime32/Std.i new file mode 100644 index 000000000..dbe2ff36d --- /dev/null +++ b/runtime32/Std.i @@ -0,0 +1,59 @@ +F,assert; +F,getEnv; +F,system; +V,sysargs; +F,stringInt; +F,makeArray; +F,string; +F,length; +F,clone; +F,hash; +F,fst; +F,snd; +F,hd; +F,tl; +F,readLine; +F,stringcat; +F,matchSubString; +F,substring; +F,regexp; +F,regexpMatch; +F,sprintf; +F,makeString; +F,printf; +F,fprintf; +F,fopen; +F,fclose; +F,fread; +F,fwrite; +F,fexists; +F,failure; +F,read; +F,write; +F,compare; +F,i__Infix_4343; +F,s__Infix_58; +F,s__Infix_3333; +F,s__Infix_3838; +F,s__Infix_6161; +F,s__Infix_3361; +F,s__Infix_6061; +F,s__Infix_60; +F,s__Infix_6261; +F,s__Infix_62; +F,s__Infix_43; +F,s__Infix_45; +F,s__Infix_42; +F,s__Infix_47; +F,s__Infix_37; +L,"++",T,"+"; +F,enableGC; +F,disableGC; +F,random; +F,time; +F,kindOf; +F,compareTags; +F,flatCompare; +F,tagHash; +F,uppercase; +F,lowercase; diff --git a/runtime32/gc_runtime.s b/runtime32/gc_runtime.s new file mode 100644 index 000000000..5abc9d72e --- /dev/null +++ b/runtime32/gc_runtime.s @@ -0,0 +1,116 @@ + .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 __gc_init + .globl __gc_root_scan_stack + .globl __gc_stack_top + .globl __gc_stack_bottom + .extern init_pool + .extern gc_test_and_copy_root + .text + +__gc_init: movl %ebp, __gc_stack_bottom + addl $4, __gc_stack_bottom + call __init + 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 diff --git a/runtime32/gr.dot b/runtime32/gr.dot new file mode 100644 index 000000000..8e5acb654 --- /dev/null +++ b/runtime32/gr.dot @@ -0,0 +1,2 @@ + "runtime/" -> "negative_scenarios/"; + "runtime/" -> "negative_scenarios/"; diff --git a/runtime32/runtime.c b/runtime32/runtime.c new file mode 100644 index 000000000..5f799c0eb --- /dev/null +++ b/runtime32/runtime.c @@ -0,0 +1,2102 @@ +/* Runtime library */ + +# define _GNU_SOURCE 1 + +# include "runtime.h" + +# define __ENABLE_GC__ +# ifndef __ENABLE_GC__ +# define alloc malloc +# endif + +//# define DEBUG_PRINT 1 + +#ifdef DEBUG_PRINT +int indent = 0; +void print_indent (void) { + for (int i = 0; i < indent; i++) printf (" "); + printf("| "); +} +#endif + +extern size_t __gc_stack_top, __gc_stack_bottom; + +/* GC pool structure and data; declared here in order to allow debug print */ +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; +/* end */ + +# ifdef __ENABLE_GC__ + +/* GC extern invariant for built-in functions */ +extern void __pre_gc (); +extern void __post_gc (); + +# else + +# define __pre_gc __pre_gc_subst +# define __post_gc __post_gc_subst + +void __pre_gc_subst () {} +void __post_gc_subst () {} + +# endif +/* end */ + +# define STRING_TAG 0x00000001 +# define ARRAY_TAG 0x00000003 +# define SEXP_TAG 0x00000005 +# define CLOSURE_TAG 0x00000007 +# define UNBOXED_TAG 0x00000009 // Not actually a tag; used to return from LkindOf + +# 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))) +# ifdef DEBUG_PRINT // GET_SEXP_TAG is necessary for printing from space +# define GET_SEXP_TAG(x) (LEN(x)) +#endif + +# define UNBOXED(x) (((int) (x)) & 0x0001) +# define UNBOX(x) (((int) (x)) >> 1) +# define BOX(x) ((((int) (x)) << 1) | 0x0001) + +/* GC extra roots */ +# define MAX_EXTRA_ROOTS_NUMBER 32 +typedef struct { + int current_free; + void ** roots[MAX_EXTRA_ROOTS_NUMBER]; +} extra_roots_pool; + +static extra_roots_pool extra_roots; + +void clear_extra_roots (void) { + extra_roots.current_free = 0; +} + +void push_extra_root (void ** p) { +# ifdef DEBUG_PRINT + indent++; print_indent (); + printf ("push_extra_root %p %p\n", p, &p); fflush (stdout); +# endif + if (extra_roots.current_free >= MAX_EXTRA_ROOTS_NUMBER) { + perror ("ERROR: push_extra_roots: extra_roots_pool overflow"); + exit (1); + } + extra_roots.roots[extra_roots.current_free] = p; + extra_roots.current_free++; +# ifdef DEBUG_PRINT + indent--; +# endif +} + +void pop_extra_root (void ** p) { +# ifdef DEBUG_PRINT + indent++; print_indent (); + printf ("pop_extra_root %p %p\n", p, &p); fflush (stdout); +# endif + if (extra_roots.current_free == 0) { + perror ("ERROR: pop_extra_root: extra_roots are empty"); + exit (1); + } + extra_roots.current_free--; + if (extra_roots.roots[extra_roots.current_free] != p) { +# ifdef DEBUG_PRINT + print_indent (); + printf ("%i %p %p", extra_roots.current_free, + extra_roots.roots[extra_roots.current_free], p); + fflush (stdout); +# endif + perror ("ERROR: pop_extra_root: stack invariant violation"); + exit (1); + } +# ifdef DEBUG_PRINT + indent--; +# endif +} + +/* end */ + +static void vfailure (char *s, va_list args) { + fflush (stdout); + fprintf (stderr, "*** FAILURE: "); + vfprintf (stderr, s, args); // vprintf (char *, va_list) <-> printf (char *, ...) + exit (255); +} + +void failure (char *s, ...) { + va_list args; + + va_start (args, s); + vfailure (s, args); +} + +void Lassert (void *f, char *s, ...) { + if (!UNBOX(f)) { + va_list args; + + va_start (args, s); + vfailure (s, args); + } +} + +# define ASSERT_BOXED(memo, x) \ + do if (UNBOXED(x)) failure ("boxed value expected in %s\n", memo); while (0) +# define ASSERT_UNBOXED(memo, x) \ + do if (!UNBOXED(x)) failure ("unboxed value expected in %s\n", memo); while (0) +# define ASSERT_STRING(memo, x) \ + do if (!UNBOXED(x) && TAG(TO_DATA(x)->tag) \ + != STRING_TAG) failure ("string value expected in %s\n", memo); while (0) + +typedef struct { + int tag; + char contents[0]; +} data; + +typedef struct { + int tag; + data contents; +} sexp; + +extern void* alloc (size_t); +extern void* Bsexp (int n, ...); +extern int LtagHash (char*); + +void *global_sysargs; + +// Gets a raw tag +extern int LkindOf (void *p) { + if (UNBOXED(p)) return UNBOXED_TAG; + + return TAG(TO_DATA(p)->tag); +} + +// Compare sexprs tags +extern int LcompareTags (void *p, void *q) { + data *pd, *qd; + + ASSERT_BOXED ("compareTags, 0", p); + ASSERT_BOXED ("compareTags, 1", q); + + pd = TO_DATA(p); + qd = TO_DATA(q); + + if (TAG(pd->tag) == SEXP_TAG && TAG(qd->tag) == SEXP_TAG) { + return + #ifndef DEBUG_PRINT + BOX((TO_SEXP(p)->tag) - (TO_SEXP(q)->tag)); + #else + BOX((GET_SEXP_TAG(TO_SEXP(p)->tag)) - (GET_SEXP_TAG(TO_SEXP(p)->tag))); + #endif + } + else failure ("not a sexpr in compareTags: %d, %d\n", TAG(pd->tag), TAG(qd->tag)); + + return 0; // never happens +} + +// Functional synonym for built-in operator ":"; +void* Ls__Infix_58 (void *p, void *q) { + void *res; + + __pre_gc (); + + push_extra_root(&p); + push_extra_root(&q); + res = Bsexp (BOX(3), p, q, LtagHash ("cons")); //BOX(848787)); + pop_extra_root(&q); + pop_extra_root(&p); + + __post_gc (); + + return res; +} + +// Functional synonym for built-in operator "!!"; +int Ls__Infix_3333 (void *p, void *q) { + ASSERT_UNBOXED("captured !!:1", p); + ASSERT_UNBOXED("captured !!:2", q); + + return BOX(UNBOX(p) || UNBOX(q)); +} + +// Functional synonym for built-in operator "&&"; +int Ls__Infix_3838 (void *p, void *q) { + ASSERT_UNBOXED("captured &&:1", p); + ASSERT_UNBOXED("captured &&:2", q); + + return BOX(UNBOX(p) && UNBOX(q)); +} + +// Functional synonym for built-in operator "=="; +int Ls__Infix_6161 (void *p, void *q) { + return BOX(p == q); +} + +// Functional synonym for built-in operator "!="; +int Ls__Infix_3361 (void *p, void *q) { + ASSERT_UNBOXED("captured !=:1", p); + ASSERT_UNBOXED("captured !=:2", q); + + return BOX(UNBOX(p) != UNBOX(q)); +} + +// Functional synonym for built-in operator "<="; +int Ls__Infix_6061 (void *p, void *q) { + ASSERT_UNBOXED("captured <=:1", p); + ASSERT_UNBOXED("captured <=:2", q); + + return BOX(UNBOX(p) <= UNBOX(q)); +} + +// Functional synonym for built-in operator "<"; +int Ls__Infix_60 (void *p, void *q) { + ASSERT_UNBOXED("captured <:1", p); + ASSERT_UNBOXED("captured <:2", q); + + return BOX(UNBOX(p) < UNBOX(q)); +} + +// Functional synonym for built-in operator ">="; +int Ls__Infix_6261 (void *p, void *q) { + ASSERT_UNBOXED("captured >=:1", p); + ASSERT_UNBOXED("captured >=:2", q); + + return BOX(UNBOX(p) >= UNBOX(q)); +} + +// Functional synonym for built-in operator ">"; +int Ls__Infix_62 (void *p, void *q) { + ASSERT_UNBOXED("captured >:1", p); + ASSERT_UNBOXED("captured >:2", q); + + return BOX(UNBOX(p) > UNBOX(q)); +} + +// Functional synonym for built-in operator "+"; +int Ls__Infix_43 (void *p, void *q) { + ASSERT_UNBOXED("captured +:1", p); + ASSERT_UNBOXED("captured +:2", q); + + return BOX(UNBOX(p) + UNBOX(q)); +} + +// Functional synonym for built-in operator "-"; +int Ls__Infix_45 (void *p, void *q) { + if (UNBOXED(p)) { + ASSERT_UNBOXED("captured -:2", q); + return BOX(UNBOX(p) - UNBOX(q)); + } + + ASSERT_BOXED("captured -:1", q); + return BOX(p - q); +} + +// Functional synonym for built-in operator "*"; +int Ls__Infix_42 (void *p, void *q) { + ASSERT_UNBOXED("captured *:1", p); + ASSERT_UNBOXED("captured *:2", q); + + return BOX(UNBOX(p) * UNBOX(q)); +} + +// Functional synonym for built-in operator "/"; +int Ls__Infix_47 (void *p, void *q) { + ASSERT_UNBOXED("captured /:1", p); + ASSERT_UNBOXED("captured /:2", q); + + return BOX(UNBOX(p) / UNBOX(q)); +} + +// Functional synonym for built-in operator "%"; +int Ls__Infix_37 (void *p, void *q) { + ASSERT_UNBOXED("captured %:1", p); + ASSERT_UNBOXED("captured %:2", q); + + return BOX(UNBOX(p) % UNBOX(q)); +} + +extern int Llength (void *p) { + data *a = (data*) BOX (NULL); + + ASSERT_BOXED(".length", p); + + a = TO_DATA(p); + return BOX(LEN(a->tag)); +} + +static char* chars = "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'"; + +extern char* de_hash (int); + +extern int LtagHash (char *s) { + char *p; + int h = 0, limit = 0; + + p = s; + + while (*p && limit++ <= 4) { + char *q = chars; + int pos = 0; + + for (; *q && *q != *p; q++, pos++); + + if (*q) h = (h << 6) | pos; + else failure ("tagHash: character not found: %c\n", *p); + + p++; + } + + if (strncmp (s, de_hash (h), 5) != 0) { + failure ("%s <-> %s\n", s, de_hash(h)); + } + + return BOX(h); +} + +char* de_hash (int n) { + // static char *chars = (char*) BOX (NULL); + static char buf[6] = {0,0,0,0,0,0}; + char *p = (char *) BOX (NULL); + p = &buf[5]; + +#ifdef DEBUG_PRINT + indent++; print_indent (); + printf ("de_hash: tag: %d\n", n); fflush (stdout); +#endif + + *p-- = 0; + + while (n != 0) { +#ifdef DEBUG_PRINT + print_indent (); + printf ("char: %c\n", chars [n & 0x003F]); fflush (stdout); +#endif + *p-- = chars [n & 0x003F]; + n = n >> 6; + } + +#ifdef DEBUG_PRINT + indent--; +#endif + + return ++p; +} + +typedef struct { + char *contents; + int ptr; + int len; +} StringBuf; + +static StringBuf stringBuf; + +# define STRINGBUF_INIT 128 + +static void createStringBuf () { + stringBuf.contents = (char*) malloc (STRINGBUF_INIT); + memset(stringBuf.contents, 0, STRINGBUF_INIT); + stringBuf.ptr = 0; + stringBuf.len = STRINGBUF_INIT; +} + +static void deleteStringBuf () { + free (stringBuf.contents); +} + +static void extendStringBuf () { + int len = stringBuf.len << 1; + + stringBuf.contents = (char*) realloc (stringBuf.contents, len); + stringBuf.len = len; +} + +static void vprintStringBuf (char *fmt, va_list args) { + int written = 0, + rest = 0; + char *buf = (char*) BOX(NULL); + va_list vsnargs; + + again: + va_copy (vsnargs, args); + + buf = &stringBuf.contents[stringBuf.ptr]; + rest = stringBuf.len - stringBuf.ptr; + + written = vsnprintf (buf, rest, fmt, vsnargs); + + va_end(vsnargs); + + if (written >= rest) { + extendStringBuf (); + goto again; + } + + stringBuf.ptr += written; +} + +static void printStringBuf (char *fmt, ...) { + va_list args; + + va_start (args, fmt); + vprintStringBuf (fmt, args); +} + +int is_valid_heap_pointer (void *p); + +static void printValue (void *p) { + data *a = (data*) BOX(NULL); + int i = BOX(0); + if (UNBOXED(p)) printStringBuf ("%d", UNBOX(p)); + else { + if (! is_valid_heap_pointer(p)) { + printStringBuf ("0x%x", p); + return; + } + + a = TO_DATA(p); + + switch (TAG(a->tag)) { + case STRING_TAG: + printStringBuf ("\"%s\"", a->contents); + break; + + case CLOSURE_TAG: + printStringBuf ("tag); i++) { + if (i) printValue ((void*)((int*) a->contents)[i]); + else printStringBuf ("0x%x", (void*)((int*) a->contents)[i]); + + if (i != LEN(a->tag) - 1) printStringBuf (", "); + } + printStringBuf (">"); + break; + + case ARRAY_TAG: + printStringBuf ("["); + for (i = 0; i < LEN(a->tag); i++) { + printValue ((void*)((int*) a->contents)[i]); + if (i != LEN(a->tag) - 1) printStringBuf (", "); + } + printStringBuf ("]"); + break; + + case SEXP_TAG: { +#ifndef DEBUG_PRINT + char * tag = de_hash (TO_SEXP(p)->tag); +#else + char * tag = de_hash (GET_SEXP_TAG(TO_SEXP(p)->tag)); +#endif + + if (strcmp (tag, "cons") == 0) { + data *b = a; + + printStringBuf ("{"); + + while (LEN(a->tag)) { + printValue ((void*)((int*) b->contents)[0]); + b = (data*)((int*) b->contents)[1]; + if (! UNBOXED(b)) { + printStringBuf (", "); + b = TO_DATA(b); + } + else break; + } + + printStringBuf ("}"); + } + else { + printStringBuf ("%s", tag); + if (LEN(a->tag)) { + printStringBuf (" ("); + for (i = 0; i < LEN(a->tag); i++) { + printValue ((void*)((int*) a->contents)[i]); + if (i != LEN(a->tag) - 1) printStringBuf (", "); + } + printStringBuf (")"); + } + } + } + break; + + default: + printStringBuf ("*** invalid tag: 0x%x ***", TAG(a->tag)); + } + } +} + +static void stringcat (void *p) { + data *a; + int i; + + if (UNBOXED(p)) ; + else { + a = TO_DATA(p); + + switch (TAG(a->tag)) { + case STRING_TAG: + printStringBuf ("%s", a->contents); + break; + + case SEXP_TAG: { +#ifndef DEBUG_PRINT + char * tag = de_hash (TO_SEXP(p)->tag); +#else + char * tag = de_hash (GET_SEXP_TAG(TO_SEXP(p)->tag)); +#endif + if (strcmp (tag, "cons") == 0) { + data *b = a; + + while (LEN(a->tag)) { + stringcat ((void*)((int*) b->contents)[0]); + b = (data*)((int*) b->contents)[1]; + if (! UNBOXED(b)) { + b = TO_DATA(b); + } + else break; + } + } + else printStringBuf ("*** non-list tag: %s ***", tag); + } + break; + + default: + printStringBuf ("*** invalid tag: 0x%x ***", TAG(a->tag)); + } + } +} + +extern int Luppercase (void *v) { + ASSERT_UNBOXED("Luppercase:1", v); + return BOX(toupper ((int) UNBOX(v))); +} + +extern int Llowercase (void *v) { + ASSERT_UNBOXED("Llowercase:1", v); + return BOX(tolower ((int) UNBOX(v))); +} + +extern int LmatchSubString (char *subj, char *patt, int pos) { + data *p = TO_DATA(patt), *s = TO_DATA(subj); + int n; + + ASSERT_STRING("matchSubString:1", subj); + ASSERT_STRING("matchSubString:2", patt); + ASSERT_UNBOXED("matchSubString:3", pos); + + n = LEN (p->tag); + + if (n + UNBOX(pos) > LEN(s->tag)) + return BOX(0); + + return BOX(strncmp (subj + UNBOX(pos), patt, n) == 0); +} + +extern void* Lsubstring (void *subj, int p, int l) { + data *d = TO_DATA(subj); + int pp = UNBOX (p), ll = UNBOX (l); + + ASSERT_STRING("substring:1", subj); + ASSERT_UNBOXED("substring:2", p); + ASSERT_UNBOXED("substring:3", l); + + if (pp + ll <= LEN(d->tag)) { + data *r; + + __pre_gc (); + + push_extra_root (&subj); + r = (data*) alloc (ll + 1 + sizeof (int)); + pop_extra_root (&subj); + + r->tag = STRING_TAG | (ll << 3); + + strncpy (r->contents, (char*) subj + pp, ll); + + __post_gc (); + + return r->contents; + } + + failure ("substring: index out of bounds (position=%d, length=%d, \ + subject length=%d)", pp, ll, LEN(d->tag)); +} + +extern struct re_pattern_buffer *Lregexp (char *regexp) { + regex_t *b = (regex_t*) malloc (sizeof (regex_t)); + + /* printf ("regexp: %s,\t%x\n", regexp, b); */ + + memset (b, 0, sizeof (regex_t)); + + int n = (int) re_compile_pattern (regexp, strlen (regexp), b); + + if (n != 0) { + failure ("%", strerror (n)); + }; + + return b; +} + +extern int LregexpMatch (struct re_pattern_buffer *b, char *s, int pos) { + int res; + + ASSERT_BOXED("regexpMatch:1", b); + ASSERT_STRING("regexpMatch:2", s); + ASSERT_UNBOXED("regexpMatch:3", pos); + + res = re_match (b, s, LEN(TO_DATA(s)->tag), UNBOX(pos), 0); + + /* printf ("regexpMatch %x: %s, res=%d\n", b, s+UNBOX(pos), res); */ + + if (res) { + return BOX (res); + } + + return BOX (res); +} + +extern void* Bstring (void*); + +void *Lclone (void *p) { + data *obj; + sexp *sobj; + void* res; + int n; +#ifdef DEBUG_PRINT + register int * ebp asm ("ebp"); + indent++; print_indent (); + printf ("Lclone arg: %p %p\n", &p, p); fflush (stdout); +#endif + __pre_gc (); + + if (UNBOXED(p)) return p; + else { + data *a = TO_DATA(p); + int t = TAG(a->tag), l = LEN(a->tag); + + push_extra_root (&p); + switch (t) { + case STRING_TAG: +#ifdef DEBUG_PRINT + print_indent (); + printf ("Lclone: string1 &p=%p p=%p\n", &p, p); fflush (stdout); +#endif + res = Bstring (TO_DATA(p)->contents); +#ifdef DEBUG_PRINT + print_indent (); + printf ("Lclone: string2 %p %p\n", &p, p); fflush (stdout); +#endif + break; + + case ARRAY_TAG: + case CLOSURE_TAG: +#ifdef DEBUG_PRINT + print_indent (); + printf ("Lclone: closure or array &p=%p p=%p ebp=%p\n", &p, p, ebp); fflush (stdout); +#endif + obj = (data*) alloc (sizeof(int) * (l+1)); + memcpy (obj, TO_DATA(p), sizeof(int) * (l+1)); + res = (void*) (obj->contents); + break; + + case SEXP_TAG: +#ifdef DEBUG_PRINT + print_indent (); printf ("Lclone: sexp\n"); fflush (stdout); +#endif + sobj = (sexp*) alloc (sizeof(int) * (l+2)); + memcpy (sobj, TO_SEXP(p), sizeof(int) * (l+2)); + res = (void*) sobj->contents.contents; + break; + + default: + failure ("invalid tag %d in clone *****\n", t); + } + pop_extra_root (&p); + } +#ifdef DEBUG_PRINT + print_indent (); printf ("Lclone ends1\n"); fflush (stdout); +#endif + + __post_gc (); +#ifdef DEBUG_PRINT + print_indent (); + printf ("Lclone ends2\n"); fflush (stdout); + indent--; +#endif + return res; +} + +# define HASH_DEPTH 3 +# define HASH_APPEND(acc, x) (((acc + (unsigned) x) << (WORD_SIZE / 2)) | ((acc + (unsigned) x) >> (WORD_SIZE / 2))) + +int inner_hash (int depth, unsigned acc, void *p) { + if (depth > HASH_DEPTH) return acc; + + if (UNBOXED(p)) return HASH_APPEND(acc, UNBOX(p)); + else if (is_valid_heap_pointer (p)) { + data *a = TO_DATA(p); + int t = TAG(a->tag), l = LEN(a->tag), i; + + acc = HASH_APPEND(acc, t); + acc = HASH_APPEND(acc, l); + + switch (t) { + case STRING_TAG: { + char *p = a->contents; + + while (*p) { + int n = (int) *p++; + acc = HASH_APPEND(acc, n); + } + + return acc; + } + + case CLOSURE_TAG: + acc = HASH_APPEND(acc, ((void**) a->contents)[0]); + i = 1; + break; + + case ARRAY_TAG: + i = 0; + break; + + case SEXP_TAG: { +#ifndef DEBUG_PRINT + int ta = TO_SEXP(p)->tag; +#else + int ta = GET_SEXP_TAG(TO_SEXP(p)->tag); +#endif + acc = HASH_APPEND(acc, ta); + i = 0; + break; + } + + default: + failure ("invalid tag %d in hash *****\n", t); + } + + for (; icontents)[i]); + + return acc; + } + else return HASH_APPEND(acc, p); +} + +extern void* LstringInt (char *b) { + int n; + sscanf (b, "%d", &n); + return (void*) BOX(n); +} + +extern int Lhash (void *p) { + return BOX(0x3fffff & inner_hash (0, 0, p)); +} + +extern int LflatCompare (void *p, void *q) { + if (UNBOXED(p)) { + if (UNBOXED(q)) { + return BOX (UNBOX(p) - UNBOX(q)); + } + + return -1; + } + else if (~UNBOXED(q)) { + return BOX(p - q); + } + else BOX(1); +} + +extern int Lcompare (void *p, void *q) { +# define COMPARE_AND_RETURN(x,y) do if (x != y) return BOX(x - y); while (0) + + if (p == q) return BOX(0); + + if (UNBOXED(p)) { + if (UNBOXED(q)) return BOX(UNBOX(p) - UNBOX(q)); + else return BOX(-1); + } + else if (UNBOXED(q)) return BOX(1); + else { + if (is_valid_heap_pointer (p)) { + if (is_valid_heap_pointer (q)) { + data *a = TO_DATA(p), *b = TO_DATA(q); + int ta = TAG(a->tag), tb = TAG(b->tag); + int la = LEN(a->tag), lb = LEN(b->tag); + int i; + + COMPARE_AND_RETURN (ta, tb); + + switch (ta) { + case STRING_TAG: + return BOX(strcmp (a->contents, b->contents)); + + case CLOSURE_TAG: + COMPARE_AND_RETURN (((void**) a->contents)[0], ((void**) b->contents)[0]); + COMPARE_AND_RETURN (la, lb); + i = 1; + break; + + case ARRAY_TAG: + COMPARE_AND_RETURN (la, lb); + i = 0; + break; + + case SEXP_TAG: { +#ifndef DEBUG_PRINT + int ta = TO_SEXP(p)->tag, tb = TO_SEXP(q)->tag; +#else + int ta = GET_SEXP_TAG(TO_SEXP(p)->tag), tb = GET_SEXP_TAG(TO_SEXP(q)->tag); +#endif + COMPARE_AND_RETURN (ta, tb); + COMPARE_AND_RETURN (la, lb); + i = 0; + break; + } + + default: + failure ("invalid tag %d in compare *****\n", ta); + } + + for (; icontents)[i], ((void**) b->contents)[i]); + if (c != BOX(0)) return BOX(c); + } + + return BOX(0); + } + else return BOX(-1); + } + else if (is_valid_heap_pointer (q)) return BOX(1); + else return BOX (p - q); + } +} + +extern void* Belem (void *p, int i) { + data *a = (data *)BOX(NULL); + + ASSERT_BOXED(".elem:1", p); + ASSERT_UNBOXED(".elem:2", i); + + a = TO_DATA(p); + i = UNBOX(i); + + if (TAG(a->tag) == STRING_TAG) { + return (void*) BOX(a->contents[i]); + } + + return (void*) ((int*) a->contents)[i]; +} + +extern void* LmakeArray (int length) { + data *r; + int n, *p; + + ASSERT_UNBOXED("makeArray:1", length); + + __pre_gc (); + + n = UNBOX(length); + r = (data*) alloc (sizeof(int) * (n+1)); + + r->tag = ARRAY_TAG | (n << 3); + + p = (int*) r->contents; + while (n--) *p++ = BOX(0); + + __post_gc (); + + return r->contents; +} + +extern void* LmakeString (int length) { + int n = UNBOX(length); + data *r; + + ASSERT_UNBOXED("makeString", length); + + __pre_gc () ; + + r = (data*) alloc (n + 1 + sizeof (int)); + + r->tag = STRING_TAG | (n << 3); + + __post_gc(); + + return r->contents; +} + +extern void* Bstring (void *p) { + int n = strlen (p); + data *s = NULL; + + __pre_gc (); +#ifdef DEBUG_PRINT + indent++; print_indent (); + printf ("Bstring: call LmakeString %s %p %p %p %i\n", p, &p, p, s, n); + fflush(stdout); +#endif + push_extra_root (&p); + s = LmakeString (BOX(n)); + pop_extra_root(&p); +#ifdef DEBUG_PRINT + print_indent (); + printf ("\tBstring: call strncpy: %p %p %p %i\n", &p, p, s, n); fflush(stdout); +#endif + strncpy ((char*)s, p, n + 1); +#ifdef DEBUG_PRINT + print_indent (); + printf ("\tBstring: ends\n"); fflush(stdout); + indent--; +#endif + __post_gc (); + + return s; +} + +extern void* Lstringcat (void *p) { + void *s; + + /* ASSERT_BOXED("stringcat", p); */ + + __pre_gc (); + + createStringBuf (); + stringcat (p); + + push_extra_root(&p); + s = Bstring (stringBuf.contents); + pop_extra_root(&p); + + deleteStringBuf (); + + __post_gc (); + + return s; +} + +extern void* Lstring (void *p) { + void *s = (void *) BOX (NULL); + + __pre_gc () ; + + createStringBuf (); + printValue (p); + + push_extra_root(&p); + s = Bstring (stringBuf.contents); + pop_extra_root(&p); + + deleteStringBuf (); + + __post_gc (); + + return s; +} + +extern void* Bclosure (int bn, void *entry, ...) { + va_list args; + int i, ai; + register int * ebp asm ("ebp"); + size_t *argss; + data *r; + int n = UNBOX(bn); + + __pre_gc (); +#ifdef DEBUG_PRINT + indent++; print_indent (); + printf ("Bclosure: create n = %d\n", n); fflush(stdout); +#endif + argss = (ebp + 12); + for (i = 0; itag = CLOSURE_TAG | ((n + 1) << 3); + ((void**) r->contents)[0] = entry; + + va_start(args, entry); + + for (i = 0; icontents)[i+1] = ai; + } + + va_end(args); + + __post_gc(); + + argss--; + for (i = 0; icontents; +} + +extern void* Barray (int bn, ...) { + va_list args; + int i, ai; + data *r; + int n = UNBOX(bn); + + __pre_gc (); + +#ifdef DEBUG_PRINT + indent++; print_indent (); + 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, bn); + + for (i = 0; icontents)[i] = ai; + } + + va_end(args); + + __post_gc(); +#ifdef DEBUG_PRINT + indent--; +#endif + return r->contents; +} + +extern void* Bsexp (int bn, ...) { + va_list args; + int i; + int ai; + size_t *p; + sexp *r; + data *d; + int n = UNBOX(bn); + + __pre_gc () ; + +#ifdef DEBUG_PRINT + indent++; print_indent (); + printf("Bsexp: allocate %zu!\n",sizeof(int) * (n+1)); fflush (stdout); +#endif + r = (sexp*) alloc (sizeof(int) * (n+1)); + d = &(r->contents); + r->tag = 0; + + d->tag = SEXP_TAG | ((n-1) << 3); + + va_start(args, bn); + + for (i=0; icontents)[i] = ai; + } + + r->tag = UNBOX(va_arg(args, int)); + +#ifdef DEBUG_PRINT + r->tag = SEXP_TAG | ((r->tag) << 3); + print_indent (); + printf("Bsexp: ends\n"); fflush (stdout); + indent--; +#endif + + va_end(args); + + __post_gc(); + + return d->contents; +} + +extern int Btag (void *d, int t, int n) { + data *r; + + if (UNBOXED(d)) return BOX(0); + else { + r = TO_DATA(d); +#ifndef DEBUG_PRINT + return BOX(TAG(r->tag) == SEXP_TAG && TO_SEXP(d)->tag == UNBOX(t) && LEN(r->tag) == UNBOX(n)); +#else + return BOX(TAG(r->tag) == SEXP_TAG && + GET_SEXP_TAG(TO_SEXP(d)->tag) == UNBOX(t) && LEN(r->tag) == UNBOX(n)); +#endif + } +} + +extern int Barray_patt (void *d, int n) { + data *r; + + if (UNBOXED(d)) return BOX(0); + else { + r = TO_DATA(d); + return BOX(TAG(r->tag) == ARRAY_TAG && LEN(r->tag) == UNBOX(n)); + } +} + +extern int Bstring_patt (void *x, void *y) { + data *rx = (data *) BOX (NULL), + *ry = (data *) BOX (NULL); + + ASSERT_STRING(".string_patt:2", y); + + if (UNBOXED(x)) return BOX(0); + else { + rx = TO_DATA(x); ry = TO_DATA(y); + + if (TAG(rx->tag) != STRING_TAG) return BOX(0); + + return BOX(strcmp (rx->contents, ry->contents) == 0 ? 1 : 0); + } +} + +extern int Bclosure_tag_patt (void *x) { + if (UNBOXED(x)) return BOX(0); + + return BOX(TAG(TO_DATA(x)->tag) == CLOSURE_TAG); +} + +extern int Bboxed_patt (void *x) { + return BOX(UNBOXED(x) ? 0 : 1); +} + +extern int Bunboxed_patt (void *x) { + return BOX(UNBOXED(x) ? 1 : 0); +} + +extern int Barray_tag_patt (void *x) { + if (UNBOXED(x)) return BOX(0); + + return BOX(TAG(TO_DATA(x)->tag) == ARRAY_TAG); +} + +extern int Bstring_tag_patt (void *x) { + if (UNBOXED(x)) return BOX(0); + + return BOX(TAG(TO_DATA(x)->tag) == STRING_TAG); +} + +extern int Bsexp_tag_patt (void *x) { + if (UNBOXED(x)) return BOX(0); + + return BOX(TAG(TO_DATA(x)->tag) == SEXP_TAG); +} + +extern void* Bsta (void *v, int i, void *x) { + if (UNBOXED(i)) { + ASSERT_BOXED(".sta:3", x); + // ASSERT_UNBOXED(".sta:2", i); + + if (TAG(TO_DATA(x)->tag) == STRING_TAG)((char*) x)[UNBOX(i)] = (char) UNBOX(v); + else ((int*) x)[UNBOX(i)] = (int) v; + + return v; + } + + * (void**) x = v; + + return v; +} + +static void fix_unboxed (char *s, va_list va) { + size_t *p = (size_t*)va; + int i = 0; + + while (*s) { + if (*s == '%') { + size_t n = p [i]; + if (UNBOXED (n)) { + p[i] = UNBOX(n); + } + i++; + } + s++; + } +} + +extern void Lfailure (char *s, ...) { + va_list args; + + va_start (args, s); + fix_unboxed (s, args); + vfailure (s, args); +} + +extern void Bmatch_failure (void *v, char *fname, int line, int col) { + createStringBuf (); + printValue (v); + failure ("match failure at %s:%d:%d, value '%s'\n", + fname, UNBOX(line), UNBOX(col), stringBuf.contents); +} + +extern void* /*Lstrcat*/ Li__Infix_4343 (void *a, void *b) { + data *da = (data*) BOX (NULL); + data *db = (data*) BOX (NULL); + data *d = (data*) BOX (NULL); + + ASSERT_STRING("++:1", a); + ASSERT_STRING("++:2", b); + + da = TO_DATA(a); + db = TO_DATA(b); + + __pre_gc () ; + + push_extra_root (&a); + push_extra_root (&b); + d = (data *) alloc (sizeof(int) + LEN(da->tag) + LEN(db->tag) + 1); + pop_extra_root (&b); + pop_extra_root (&a); + + da = TO_DATA(a); + db = TO_DATA(b); + + d->tag = STRING_TAG | ((LEN(da->tag) + LEN(db->tag)) << 3); + + strncpy (d->contents , da->contents, LEN(da->tag)); + strncpy (d->contents + LEN(da->tag), db->contents, LEN(db->tag)); + + d->contents[LEN(da->tag) + LEN(db->tag)] = 0; + + __post_gc(); + + return d->contents; +} + +extern void* Lsprintf (char * fmt, ...) { + va_list args; + void *s; + + ASSERT_STRING("sprintf:1", fmt); + + va_start (args, fmt); + fix_unboxed (fmt, args); + + createStringBuf (); + + vprintStringBuf (fmt, args); + + __pre_gc (); + + push_extra_root ((void**)&fmt); + s = Bstring (stringBuf.contents); + pop_extra_root ((void**)&fmt); + + __post_gc (); + + deleteStringBuf (); + + return s; +} + +extern void* LgetEnv (char *var) { + char *e = getenv (var); + void *s; + + if (e == NULL) + return BOX(0); + + __pre_gc (); + + s = Bstring (e); + + __post_gc (); + + return s; +} + +extern int Lsystem (char *cmd) { + return BOX (system (cmd)); +} + +extern void Lfprintf (FILE *f, char *s, ...) { + va_list args = (va_list) BOX (NULL); + + ASSERT_BOXED("fprintf:1", f); + ASSERT_STRING("fprintf:2", s); + + va_start (args, s); + fix_unboxed (s, args); + + if (vfprintf (f, s, args) < 0) { + failure ("fprintf (...): %s\n", strerror (errno)); + } +} + +extern void Lprintf (char *s, ...) { + va_list args = (va_list) BOX (NULL); + + ASSERT_STRING("printf:1", s); + + va_start (args, s); + fix_unboxed (s, args); + + if (vprintf (s, args) < 0) { + failure ("fprintf (...): %s\n", strerror (errno)); + } + + fflush (stdout); +} + +extern FILE* Lfopen (char *f, char *m) { + FILE* h; + + ASSERT_STRING("fopen:1", f); + ASSERT_STRING("fopen:2", m); + + h = fopen (f, m); + + if (h) + return h; + + failure ("fopen (\"%s\", \"%s\"): %s, %s, %s\n", f, m, strerror (errno)); +} + +extern void Lfclose (FILE *f) { + ASSERT_BOXED("fclose", f); + + fclose (f); +} + +extern void* LreadLine () { + char *buf; + + if (scanf ("%m[^\n]", &buf) == 1) { + void * s = Bstring (buf); + + getchar (); + + free (buf); + return s; + } + + if (errno != 0) + failure ("readLine (): %s\n", strerror (errno)); + + return (void*) BOX (0); +} + +extern void* Lfread (char *fname) { + FILE *f; + + ASSERT_STRING("fread", fname); + + f = fopen (fname, "r"); + + if (f) { + if (fseek (f, 0l, SEEK_END) >= 0) { + long size = ftell (f); + void *s = LmakeString (BOX(size)); + + rewind (f); + + if (fread (s, 1, size, f) == size) { + fclose (f); + return s; + } + } + } + + failure ("fread (\"%s\"): %s\n", fname, strerror (errno)); +} + +extern void Lfwrite (char *fname, char *contents) { + FILE *f; + + ASSERT_STRING("fwrite:1", fname); + ASSERT_STRING("fwrite:2", contents); + + f = fopen (fname, "w"); + + if (f) { + if (fprintf (f, "%s", contents) < 0); + else { + fclose (f); + return; + } + } + + failure ("fwrite (\"%s\"): %s\n", fname, strerror (errno)); +} + +extern void* Lfexists (char *fname) { + FILE *f; + + ASSERT_STRING("fexists", fname); + + f = fopen (fname, "r"); + + if (f) return BOX(1); + + return BOX(0); +} + +extern void* Lfst (void *v) { + return Belem (v, BOX(0)); +} + +extern void* Lsnd (void *v) { + return Belem (v, BOX(1)); +} + +extern void* Lhd (void *v) { + return Belem (v, BOX(0)); +} + +extern void* Ltl (void *v) { + return Belem (v, BOX(1)); +} + +/* Lread is an implementation of the "read" construct */ +extern int Lread () { + int result = BOX(0); + + printf ("> "); + fflush (stdout); + scanf ("%d", &result); + + return BOX(result); +} + +/* Lwrite is an implementation of the "write" construct */ +extern int Lwrite (int n) { + printf ("%d\n", UNBOX(n)); + fflush (stdout); + + return 0; +} + +extern int Lrandom (int n) { + ASSERT_UNBOXED("Lrandom, 0", n); + + if (UNBOX(n) <= 0) { + failure ("invalid range in random: %d\n", UNBOX(n)); + } + + return BOX (random () % UNBOX(n)); +} + +extern int Ltime () { + struct timespec t; + + clock_gettime (CLOCK_MONOTONIC_RAW, &t); + + return BOX(t.tv_sec * 1000000 + t.tv_nsec / 1000); +} + +extern void set_args (int argc, char *argv[]) { + data *a; + int n = argc, *p = NULL; + int i; + + __pre_gc (); + +#ifdef DEBUG_PRINT + indent++; print_indent (); + printf ("set_args: call: n=%i &p=%p p=%p: ", n, &p, p); fflush(stdout); + for (i = 0; i < n; i++) + printf("%s ", argv[i]); + printf("EE\n"); +#endif + + p = LmakeArray (BOX(n)); + push_extra_root ((void**)&p); + + for (i=0; i\n", i, &p, p); fflush(stdout); +#endif + ((int*)p) [i] = (int) Bstring (argv[i]); +#ifdef DEBUG_PRINT + print_indent (); + printf ("set_args: iteration %i <- %p %p\n", i, &p, p); fflush(stdout); +#endif + } + + pop_extra_root ((void**)&p); + __post_gc (); + + global_sysargs = p; + push_extra_root ((void**)&global_sysargs); +#ifdef DEBUG_PRINT + print_indent (); + printf ("set_args: end\n", n, &p, p); fflush(stdout); + indent--; +#endif +} + +/* GC starts here */ + +static int enable_GC = 1; + +extern void LenableGC () { + enable_GC = 1; +} + +extern void LdisableGC () { + enable_GC = 0; +} + +extern const size_t __start_custom_data, __stop_custom_data; + +# ifdef __ENABLE_GC__ + +extern void __gc_init (); + +# else + +# define __gc_init __gc_init_subst +void __gc_init_subst () {} + +# endif + +extern void __gc_root_scan_stack (); + +/* ======================================== */ +/* Mark-and-copy */ +/* ======================================== */ + +//static size_t SPACE_SIZE = 16; +static size_t SPACE_SIZE = 256 * 1024 * 1024; +// static size_t SPACE_SIZE = 128; +// static size_t SPACE_SIZE = 1024 * 1024; + +static int free_pool (pool * p) { + size_t *a = p->begin, b = p->size; + p->begin = NULL; + p->size = 0; + p->end = NULL; + p->current = NULL; + return munmap((void *)a, b); +} + +static void init_to_space (int flag) { + size_t space_size = 0; + if (flag) SPACE_SIZE = SPACE_SIZE << 1; + space_size = SPACE_SIZE * sizeof(size_t); + 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) { + perror ("EROOR: init_to_space: mmap failed\n"); + exit (1); + } + to_space.current = to_space.begin; + to_space.end = to_space.begin + SPACE_SIZE; + to_space.size = SPACE_SIZE; +} + +static void gc_swap_spaces (void) { +#ifdef DEBUG_PRINT + indent++; print_indent (); + printf ("gc_swap_spaces\n"); fflush (stdout); +#endif + free_pool (&from_space); + from_space.begin = to_space.begin; + from_space.current = current; + from_space.end = to_space.end; + from_space.size = to_space.size; + to_space.begin = NULL; + to_space.current = NULL; + to_space.end = NULL; + to_space.size = 0; +#ifdef DEBUG_PRINT + indent--; +#endif +} + +# define IS_VALID_HEAP_POINTER(p)\ + (!UNBOXED(p) && \ + (size_t)from_space.begin <= (size_t)p && \ + (size_t)from_space.end > (size_t)p) + +# define IN_PASSIVE_SPACE(p) \ + ((size_t)to_space.begin <= (size_t)p && \ + (size_t)to_space.end > (size_t)p) + +# define IS_FORWARD_PTR(p) \ + (!UNBOXED(p) && IN_PASSIVE_SPACE(p)) + +int is_valid_heap_pointer (void *p) { + return IS_VALID_HEAP_POINTER(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; +#ifdef DEBUG_PRINT + indent++; print_indent (); + printf ("copy_elements: start; len = %d\n", len); fflush (stdout); +#endif + for (i = 0; i < len; i++) { + size_t elem = from[i]; + if (!IS_VALID_HEAP_POINTER(elem)) { + *where = elem; + where++; +#ifdef DEBUG_PRINT + print_indent (); + printf ("copy_elements: copy NON ptr: %zu %p \n", elem, elem); fflush (stdout); +#endif + } + else { +#ifdef DEBUG_PRINT + print_indent (); + printf ("copy_elements: fix element: %p -> %p\n", elem, *where); + fflush (stdout); +#endif + p = gc_copy ((size_t*) elem); + *where = (size_t) p; + where ++; + } +#ifdef DEBUG_PRINT + print_indent (); + printf ("copy_elements: iteration end: where = %p, *where = %p, i = %d, \ + len = %d\n", where, *where, i, len); fflush (stdout); +#endif + + } +#ifdef DEBUG_PRINT + print_indent (); + printf ("\tcopy_elements: end\n"); fflush (stdout); + indent--; +#endif + +} + +static int extend_spaces (void) { + void *p = (void *) BOX (NULL); + size_t old_space_size = SPACE_SIZE * sizeof(size_t), + new_space_size = (SPACE_SIZE << 1) * sizeof(size_t); + p = mremap(to_space.begin, old_space_size, new_space_size, 0); +#ifdef DEBUG_PRINT + indent++; print_indent (); +#endif + if (p == MAP_FAILED) { +#ifdef DEBUG_PRINT + print_indent (); + printf ("extend: extend_spaces: mremap failed\n"); fflush (stdout); +#endif + return 1; + } +#ifdef DEBUG_PRINT + print_indent (); + printf ("extend: %p %p %p %p\n", p, to_space.begin, to_space.end, current); + fflush (stdout); + indent--; +#endif + to_space.end += SPACE_SIZE; + SPACE_SIZE = SPACE_SIZE << 1; + to_space.size = SPACE_SIZE; + return 0; +} + +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; + indent++; print_indent (); + printf ("gc_copy: %p cur = %p starts\n", obj, current); + fflush (stdout); +#endif + + if (!IS_VALID_HEAP_POINTER(obj)) { +#ifdef DEBUG_PRINT + print_indent (); + printf ("gc_copy: invalid ptr: %p\n", obj); fflush (stdout); + indent--; +#endif + return obj; + } + + if (!IN_PASSIVE_SPACE(current) && current != to_space.end) { +#ifdef DEBUG_PRINT + print_indent (); + printf("ERROR: gc_copy: out-of-space %p %p %p\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 + print_indent (); + printf ("gc_copy: IS_FORWARD_PTR: return! %p -> %p\n", obj, (size_t *) d->tag); + fflush(stdout); + indent--; +#endif + return (size_t *) d->tag; + } + + copy = current; +#ifdef DEBUG_PRINT + objj = d; +#endif + switch (TAG(d->tag)) { + case CLOSURE_TAG: +#ifdef DEBUG_PRINT + print_indent (); + printf ("gc_copy:closure_tag; len = %zu\n", LEN(d->tag)); fflush (stdout); +#endif + i = LEN(d->tag); + // current += LEN(d->tag) + 1; + // current += ((LEN(d->tag) + 1) * sizeof(int) -1) / sizeof(size_t) + 1; + current += i+1; + *copy = d->tag; + copy++; + d->tag = (int) copy; + copy_elements (copy, obj, i); + break; + + case ARRAY_TAG: +#ifdef DEBUG_PRINT + print_indent (); + printf ("gc_copy:array_tag; len = %zu\n", LEN(d->tag)); fflush (stdout); +#endif + current += ((LEN(d->tag) + 1) * sizeof (int) - 1) / sizeof (size_t) + 1; + *copy = d->tag; + copy++; + i = LEN(d->tag); + d->tag = (int) copy; + copy_elements (copy, obj, i); + break; + + case STRING_TAG: +#ifdef DEBUG_PRINT + print_indent (); + printf ("gc_copy:string_tag; len = %d\n", LEN(d->tag) + 1); fflush (stdout); +#endif + current += (LEN(d->tag) + sizeof(int)) / sizeof(size_t) + 1; + *copy = d->tag; + copy++; + d->tag = (int) copy; + strcpy ((char*)©[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); + print_indent (); + printf ("gc_copy:sexp_tag; len1 = %li, len2=%li, len3 = %li\n", + len1, len2, len3); + fflush (stdout); +#endif + i = LEN(s->contents.tag); + current += i + 2; + *copy = s->tag; + copy++; + *copy = d->tag; + copy++; + d->tag = (int) copy; + copy_elements (copy, obj, i); + break; + + default: +#ifdef DEBUG_PRINT + print_indent (); + printf ("ERROR: gc_copy: weird tag: %p", TAG(d->tag)); fflush (stdout); + indent--; +#endif + perror ("ERROR: gc_copy: weird tag"); + exit (1); + return (obj); + } +#ifdef DEBUG_PRINT + print_indent (); + printf ("gc_copy: %p(%p) -> %p (%p); new-current = %p\n", + obj, objj, copy, newobjj, current); + fflush (stdout); + indent--; +#endif + return copy; +} + +extern void gc_test_and_copy_root (size_t ** root) { +#ifdef DEBUG_PRINT + indent++; +#endif + if (IS_VALID_HEAP_POINTER(*root)) { +#ifdef DEBUG_PRINT + print_indent (); + printf ("gc_test_and_copy_root: root %p top=%p bot=%p *root %p \n", root, __gc_stack_top, __gc_stack_bottom, *root); + fflush (stdout); +#endif + *root = gc_copy (*root); + } +#ifdef DEBUG_PRINT + else { + print_indent (); + printf ("gc_test_and_copy_root: INVALID HEAP POINTER root %p *root %p\n", root, *root); + fflush (stdout); + } + indent--; +#endif +} + +extern void gc_root_scan_data (void) { + size_t * p = (size_t*)&__start_custom_data; + while (p < (size_t*)&__stop_custom_data) { + gc_test_and_copy_root ((size_t**)p); + p++; + } +} + +static inline void init_extra_roots (void) { + extra_roots.current_free = 0; +} + +extern void __init (void) { + size_t space_size = SPACE_SIZE * sizeof(size_t); + + srandom (time (NULL)); + + from_space.begin = mmap (NULL, space_size, PROT_READ | PROT_WRITE, + MAP_PRIVATE | MAP_ANONYMOUS | MAP_32BIT, -1, 0); + to_space.begin = NULL; + if (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 = NULL; + to_space.end = NULL; + to_space.size = 0; + init_extra_roots (); +} + +static void* gc (size_t size) { + if (! enable_GC) { + Lfailure ("GC disabled"); + } + + current = to_space.begin; +#ifdef DEBUG_PRINT + print_indent (); + printf ("gc: current:%p; to_space.b =%p; to_space.e =%p; \ + f_space.b = %p; f_space.e = %p; __gc_stack_top=%p; __gc_stack_bottom=%p\n", + current, to_space.begin, to_space.end, from_space.begin, from_space.end, + __gc_stack_top, __gc_stack_bottom); + fflush (stdout); +#endif + gc_root_scan_data (); +#ifdef DEBUG_PRINT + print_indent (); + printf ("gc: data is scanned\n"); fflush (stdout); +#endif + __gc_root_scan_stack (); + for (int i = 0; i < extra_roots.current_free; i++) { +#ifdef DEBUG_PRINT + print_indent (); + printf ("gc: extra_root № %i: %p %p\n", i, extra_roots.roots[i], + (size_t*) extra_roots.roots[i]); + fflush (stdout); +#endif + gc_test_and_copy_root ((size_t**)extra_roots.roots[i]); + } +#ifdef DEBUG_PRINT + print_indent (); + printf ("gc: no more extra roots\n"); fflush (stdout); +#endif + + if (!IN_PASSIVE_SPACE(current)) { + printf ("gc: ASSERT: !IN_PASSIVE_SPACE(current) to_begin = %p to_end = %p \ + current = %p\n", to_space.begin, to_space.end, current); + fflush (stdout); + perror ("ASSERT: !IN_PASSIVE_SPACE(current)\n"); + exit (1); + } + + while (current + size >= to_space.end) { +#ifdef DEBUG_PRINT + print_indent (); + printf ("gc: pre-extend_spaces : %p %zu %p \n", current, size, to_space.end); + fflush (stdout); +#endif + if (extend_spaces ()) { + gc_swap_spaces (); + init_to_space (1); + return gc (size); + } +#ifdef DEBUG_PRINT + print_indent (); + printf ("gc: post-extend_spaces: %p %zu %p \n", current, size, to_space.end); + fflush (stdout); +#endif + } + assert (IN_PASSIVE_SPACE(current)); + assert (current + size < to_space.end); + + gc_swap_spaces (); + from_space.current = current + size; +#ifdef DEBUG_PRINT + print_indent (); + printf ("gc: end: (allocate!) return %p; from_space.current %p; \ + from_space.end %p \n\n", + current, from_space.current, from_space.end); + fflush (stdout); + indent--; +#endif + return (void *) current; +} + +#ifdef DEBUG_PRINT +static void printFromSpace (void) { + size_t * cur = from_space.begin, *tmp = NULL; + data * d = NULL; + sexp * s = NULL; + size_t len = 0; + size_t elem_number = 0; + + printf ("\nHEAP SNAPSHOT\n===================\n"); + printf ("f_begin = %p, f_end = %p,\n", from_space.begin, from_space.end); + while (cur < from_space.current) { + printf ("data at %p", cur); + d = (data *) cur; + + switch (TAG(d->tag)) { + + case STRING_TAG: + printf ("(=>%p): STRING\n\t%s; len = %i %zu\n", + d->contents, d->contents, + LEN(d->tag), LEN(d->tag) + 1 + sizeof(int)); + fflush (stdout); + len = (LEN(d->tag) + sizeof(int)) / sizeof(size_t) + 1; + break; + + case CLOSURE_TAG: + printf ("(=>%p): CLOSURE\n\t", d->contents); + len = LEN(d->tag); + for (int i = 0; i < len; i++) { + int elem = ((int*)d->contents)[i]; + if (UNBOXED(elem)) printf ("%d ", elem); + else printf ("%p ", elem); + } + len += 1; + printf ("\n"); + fflush (stdout); + break; + + case ARRAY_TAG: + printf ("(=>%p): ARRAY\n\t", d->contents); + len = LEN(d->tag); + for (int i = 0; i < len; i++) { + int elem = ((int*)d->contents)[i]; + if (UNBOXED(elem)) printf ("%d ", elem); + else printf ("%p ", elem); + } + len += 1; + printf ("\n"); + fflush (stdout); + break; + + case SEXP_TAG: + s = (sexp *) d; + d = (data *) &(s->contents); + char * tag = de_hash (GET_SEXP_TAG(s->tag)); + printf ("(=>%p): SEXP\n\ttag(%s) ", s->contents.contents, tag); + len = LEN(d->tag); + tmp = (s->contents.contents); + for (int i = 0; i < len; i++) { + int elem = ((int*)tmp)[i]; + if (UNBOXED(elem)) printf ("%d ", UNBOX(elem)); + else printf ("%p ", elem); + } + len += 2; + printf ("\n"); + fflush (stdout); + break; + + case 0: + printf ("\nprintFromSpace: end: %zu elements\n===================\n\n", + elem_number); + return; + + default: + printf ("\nprintFromSpace: ERROR: bad tag %d", TAG(d->tag)); + perror ("\nprintFromSpace: ERROR: bad tag"); + fflush (stdout); + exit (1); + } + cur += len; + printf ("len = %zu, new cur = %p\n", len, cur); + elem_number++; + } + printf ("\nprintFromSpace: end: the whole space is printed:\ + %zu elements\n===================\n\n", elem_number); + fflush (stdout); +} +#endif + +#ifdef __ENABLE_GC__ +// alloc: allocates `size` bytes in heap +extern void * alloc (size_t size) { + void * p = (void*)BOX(NULL); + size = (size - 1) / sizeof(size_t) + 1; // convert bytes to words +#ifdef DEBUG_PRINT + indent++; print_indent (); + printf ("alloc: current: %p %zu words!", from_space.current, size); + fflush (stdout); +#endif + if (from_space.current + size < from_space.end) { + p = (void*) from_space.current; + from_space.current += size; +#ifdef DEBUG_PRINT + print_indent (); + printf (";new current: %p \n", from_space.current); fflush (stdout); + indent--; +#endif + return p; + } + + init_to_space (0); +#ifdef DEBUG_PRINT + print_indent (); + printf ("alloc: call gc: %zu\n", size); fflush (stdout); + printFromSpace(); fflush (stdout); + p = gc (size); + print_indent (); + printf("alloc: gc END %p %p %p %p\n\n", from_space.begin, + from_space.end, from_space.current, p); fflush (stdout); + printFromSpace(); fflush (stdout); + indent--; + return p; +#else + return gc (size); +#endif +} +# endif diff --git a/runtime32/runtime.h b/runtime32/runtime.h new file mode 100644 index 000000000..677429fd7 --- /dev/null +++ b/runtime32/runtime.h @@ -0,0 +1,21 @@ +# ifndef __LAMA_RUNTIME__ +# define __LAMA_RUNTIME__ + +# include +# include +# include +# include +# include +# include +# include +# include +# include +# include +# include +# include + +# define WORD_SIZE (CHAR_BIT * sizeof(int)) + +void failure (char *s, ...); + +# endif diff --git a/src/X32.ml b/src/X32.ml new file mode 100644 index 000000000..2b5418cd0 --- /dev/null +++ b/src/X32.ml @@ -0,0 +1,848 @@ +open GT +open Language +open SM + +(* X86 codegeneration interface *) + +(* The registers: *) +let regs = [|"%ebx"; "%ecx"; "%esi"; "%edi"; "%eax"; "%edx"; "%ebp"; "%esp"|] + +(* We can not freely operate with all register; only 3 by now *) +let num_of_regs = Array.length regs - 5 + +(* We need to know the word size to calculate offsets correctly *) +let word_size = 4;; + +(* We need to distinguish the following operand types: *) +@type opnd = +| R of int (* hard register *) +| S of int (* a position on the hardware stack *) +| C (* a saved closure *) +| M of string (* a named memory location *) +| L of int (* an immediate operand *) +| I of int * opnd (* an indirect operand with offset *) +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 +let esi = R 2 +let edi = R 3 +let eax = R 4 +let edx = R 5 +let ebp = R 6 +let esp = R 7 + +(* Now x86 instruction (we do not need all of them): *) +type instr = +(* copies a value from the first to the second operand *) | Mov of opnd * opnd +(* loads an address of the first operand into the second *) | Lea of opnd * opnd +(* makes a binary operation; note, the first operand *) | Binop of string * opnd * opnd +(* designates x86 operator, not the source language one *) +(* x86 integer division, see instruction set reference *) | IDiv of opnd +(* see instruction set reference *) | Cltd +(* sets a value from flags; the first operand is the *) | Set of string * string +(* suffix, which determines the value being set, the *) +(* the second --- (sub)register name *) +(* pushes the operand on the hardware stack *) | Push of opnd +(* pops from the hardware stack to the operand *) | Pop of opnd +(* call a function by a name *) | Call of string +(* call a function by indirect address *) | CallI of opnd +(* returns from a function *) | Ret +(* a label in the code *) | Label of string +(* a conditional jump *) | CJmp of string * string +(* a non-conditional jump *) | Jmp of string +(* directive *) | Meta of string + +(* arithmetic correction: decrement *) | Dec of opnd +(* 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 stack_offset i = + if i >= 0 + then (i+1) * word_size + else 8 + (-i-1) * word_size + +let show instr = + let rec opnd = function + | R i -> regs.(i) + | C -> "4(%ebp)" + | S i -> if i >= 0 + then Printf.sprintf "-%d(%%ebp)" (stack_offset i) + else Printf.sprintf "%d(%%ebp)" (stack_offset i) + | M x -> x + | L i -> Printf.sprintf "$%d" i + | I (0, x) -> Printf.sprintf "(%s)" (opnd x) + | I (n, x) -> Printf.sprintf "%d(%s)" n (opnd x) + in + let binop = function + | "+" -> "addl" + | "-" -> "subl" + | "*" -> "imull" + | "&&" -> "andl" + | "!!" -> "orl" + | "^" -> "xorl" + | "cmp" -> "cmpl" + | "test" -> "test" + | _ -> failwith "unknown binary operator" + in + match instr with + | Cltd -> "\tcltd" + | Set (suf, s) -> Printf.sprintf "\tset%s\t%s" suf s + | IDiv s1 -> Printf.sprintf "\tidivl\t%s" (opnd s1) + | Binop (op, s1, s2) -> Printf.sprintf "\t%s\t%s,\t%s" (binop op) (opnd s1) (opnd s2) + | Mov (s1, s2) -> Printf.sprintf "\tmovl\t%s,\t%s" (opnd s1) (opnd s2) + | Lea (x, y) -> Printf.sprintf "\tleal\t%s,\t%s" (opnd x) (opnd y) + | Push s -> Printf.sprintf "\tpushl\t%s" (opnd s) + | Pop s -> Printf.sprintf "\tpopl\t%s" (opnd s) + | Ret -> "\tret" + | Call p -> Printf.sprintf "\tcall\t%s" p + | CallI o -> Printf.sprintf "\tcall\t*(%s)" (opnd o) + | Label l -> Printf.sprintf "%s:\n" l + | Jmp l -> Printf.sprintf "\tjmp\t%s" l + | CJmp (s , l) -> Printf.sprintf "\tj%s\t%s" s l + | Meta s -> Printf.sprintf "%s\n" s + | Dec s -> Printf.sprintf "\tdecl\t%s" (opnd s) + | 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 + +(* Symbolic stack machine evaluator + + compile : env -> prg -> env * instr list + + Take an environment, a stack machine program, and returns a pair --- the updated environment and the list + of x86 instructions +*) +let compile cmd env imports code = + (* SM.print_prg code; *) + flush stdout; + let suffix = function + | "<" -> "l" + | "<=" -> "le" + | "==" -> "e" + | "!=" -> "ne" + | ">=" -> "ge" + | ">" -> "g" + | _ -> failwith "unknown operator" + in + let box n = (n lsl 1) lor 1 in + let rec compile' env scode = + let on_stack = function S _ -> true | _ -> false in + let mov x s = if on_stack x && on_stack s then [Mov (x, eax); Mov (eax, s)] else [Mov (x, s)] in + let callc env n tail = + let tail = tail && env#nargs = n in + if tail + then ( + let rec push_args env acc = function + | 0 -> env, acc + | n -> let x, env = env#pop in + if x = env#loc (Value.Arg (n-1)) + then push_args env acc (n-1) + else push_args env ((mov x (env#loc (Value.Arg (n-1)))) @ acc) (n-1) + in + let env , pushs = push_args env [] n in + let closure, env = env#pop in + let y , env = env#allocate in + env, pushs @ [Mov (closure, edx); + Mov (I(0, edx), eax); + Mov (ebp, esp); + Pop (ebp)] @ + (if env#has_closure then [Pop ebx] else []) @ + [Jmp "*%eax"] (* UGLY!!! *) + ) + else ( + let pushr, popr = + List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers n) + in + let pushr, popr = env#save_closure @ pushr, env#rest_closure @ popr in + let env, code = + let rec push_args env acc = function + | 0 -> env, acc + | n -> let x, env = env#pop in + push_args env ((Push x)::acc) (n-1) + in + let env, pushs = push_args env [] n in + let pushs = List.rev pushs in + let closure, env = env#pop in + let call_closure = + if on_stack closure + then [Mov (closure, edx); Mov (edx, eax); CallI eax] + else [Mov (closure, edx); CallI closure] + in + env, pushr @ pushs @ call_closure @ [Binop ("+", L (word_size * List.length pushs), esp)] @ (List.rev popr) + in + let y, env = env#allocate in env, code @ [Mov (eax, y)] + ) + in + let call env f n tail = + let tail = tail && env#nargs = n && f.[0] <> '.' in + let f = + match f.[0] with '.' -> "B" ^ String.sub f 1 (String.length f - 1) | _ -> f + in + if tail + then ( + let rec push_args env acc = function + | 0 -> env, acc + | n -> let x, env = env#pop in + if x = env#loc (Value.Arg (n-1)) + then push_args env acc (n-1) + else push_args env ((mov x (env#loc (Value.Arg (n-1)))) @ acc) (n-1) + in + let env, pushs = push_args env [] n in + let y, env = env#allocate in + env, pushs @ [Mov (ebp, esp); Pop (ebp)] @ (if env#has_closure then [Pop ebx] else []) @ [Jmp f] + ) + else ( + let pushr, popr = + List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers n) + in + let pushr, popr = env#save_closure @ pushr, env#rest_closure @ popr in + let env, code = + let rec push_args env acc = function + | 0 -> env, acc + | n -> let x, env = env#pop in + push_args env ((Push x)::acc) (n-1) + in + let env, pushs = push_args env [] n in + let pushs = + match f with + | "Barray" -> List.rev @@ (Push (L (box n))) :: pushs + | "Bsexp" -> List.rev @@ (Push (L (box n))) :: pushs + | "Bsta" -> pushs + | _ -> List.rev pushs + in + env, pushr @ pushs @ [Call f; Binop ("+", L (word_size * List.length pushs), esp)] @ (List.rev popr) + in + let y, env = env#allocate in env, code @ [Mov (eax, y)] + ) + in + match scode with + | [] -> env, [] + | instr :: scode' -> + let stack = "" (* env#show_stack*) in + (* Printf.printf "insn=%s, stack=%s\n%!" (GT.show(insn) instr) (env#show_stack); *) + let env', code' = + if env#is_barrier + then match instr with + | LABEL s -> if env#has_stack s then (env#drop_barrier)#retrieve_stack s, [Label s] else env#drop_stack, [] + | FLABEL s -> env#drop_barrier, [Label s] + | SLABEL s -> env, [Label s] + | _ -> env, [] + else + match instr with + | PUBLIC name -> env#register_public name, [] + | EXTERN name -> env#register_extern name, [] + | IMPORT name -> env, [] + + | CLOSURE (name, closure) -> + let pushr, popr = + List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers 0) + in + let closure_len = List.length closure in + let push_closure = + List.map (fun d -> Push (env#loc d)) @@ List.rev closure + in + let s, env = env#allocate in + (env, + pushr @ + push_closure @ + [Push (M ("$" ^ name)); + Push (L (box closure_len)); + Call "Bclosure"; + Binop ("+", L (word_size * (closure_len + 2)), esp); + Mov (eax, s)] @ + List.rev popr @ env#reload_closure) + + | CONST n -> + let s, env' = env#allocate in + (env', [Mov (L (box n), s)]) + + | STRING s -> + let s, env = env#string s in + let l, env = env#allocate in + let env, call = call env ".string" 1 false in + (env, Mov (M ("$" ^ s), l) :: call) + + | LDA x -> + let s, env' = (env #variable x)#allocate in + let s', env''= env'#allocate in + env'', + [Lea (env'#loc x, eax); Mov (eax, s); Mov (eax, s')] + + | LD x -> + let s, env' = (env#variable x)#allocate in + env', + (match s with + | S _ | M _ -> [Mov (env'#loc x, eax); Mov (eax, s)] + | _ -> [Mov (env'#loc x, s)] + ) + + | ST x -> + let env' = env#variable x in + let s = env'#peek in + env', + (match s with + | S _ | M _ -> [Mov (s, eax); Mov (eax, env'#loc x)] + | _ -> [Mov (s, env'#loc x)] + ) + + | STA -> + call env ".sta" 3 false + + | STI -> + let v, x, env' = env#pop2 in + env'#push x, + (match x with + | S _ | M _ -> [Mov (v, edx); Mov (x, eax); Mov (edx, I (0, eax)); Mov (edx, x)] @ env#reload_closure + | _ -> [Mov (v, eax); Mov (eax, I (0, x)); Mov (eax, x)] + ) + + | BINOP op -> + let x, y, env' = env#pop2 in + env'#push y, + (match op with + | "/" -> + [Mov (y, eax); + Sar1 eax; + Cltd; + (* x := x >> 1 ?? *) + Sar1 x; (*!!!*) + IDiv x; + Sal1 eax; + Or1 eax; + Mov (eax, y) + ] + | "%" -> + [Mov (y, eax); + Sar1 eax; + Cltd; + (* x := x >> 1 ?? *) + Sar1 x; (*!!!*) + IDiv x; + Sal1 edx; + Or1 edx; + Mov (edx, y) + ] @ env#reload_closure + | "<" | "<=" | "==" | "!=" | ">=" | ">" -> + (match x with + | M _ | S _ -> + [Binop ("^", eax, eax); + Mov (x, edx); + Binop ("cmp", edx, y); + Set (suffix op, "%al"); + Sal1 eax; + Or1 eax; + Mov (eax, y) + ] @ env#reload_closure + | _ -> + [Binop ("^" , eax, eax); + Binop ("cmp", x, y); + Set (suffix op, "%al"); + Sal1 eax; + Or1 eax; + Mov (eax, y) + ] + ) + | "*" -> + if on_stack y + then [Dec y; Mov (x, eax); Sar1 eax; Binop (op, y, eax); Or1 eax; Mov (eax, y)] + else [Dec y; Mov (x, eax); Sar1 eax; Binop (op, eax, y); Or1 y] + | "&&" -> + [Dec x; (*!!!*) + Mov (x, eax); + Binop (op, x, eax); + Mov (L 0, eax); + Set ("ne", "%al"); + + Dec y; (*!!!*) + Mov (y, edx); + Binop (op, y, edx); + Mov (L 0, edx); + Set ("ne", "%dl"); + + Binop (op, edx, eax); + Set ("ne", "%al"); + Sal1 eax; + Or1 eax; + Mov (eax, y) + ] @ env#reload_closure + | "!!" -> + [Mov (y, eax); + Sar1 eax; + Sar1 x; (*!!!*) + Binop (op, x, eax); + Mov (L 0, eax); + Set ("ne", "%al"); + Sal1 eax; + Or1 eax; + Mov (eax, y) + ] + | "+" -> + if on_stack x && on_stack y + then [Mov (x, eax); Dec eax; Binop ("+", eax, y)] + else [Binop (op, x, y); Dec y] + | "-" -> + if on_stack x && on_stack y + then [Mov (x, eax); Binop (op, eax, y); Or1 y] + else [Binop (op, x, y); Or1 y] + ) + + | LABEL s + | FLABEL s + | SLABEL s -> env, [Label s] + + | JMP l -> (env#set_stack l)#set_barrier, [Jmp l] + + | CJMP (s, l) -> + let x, env = env#pop in + env#set_stack l, [Sar1 x; (*!!!*) Binop ("cmp", L 0, x); CJmp (s, l)] + + | BEGIN (f, nargs, nlocals, closure, args, scopes) -> + let rec stabs_scope scope = + let names = + List.map + (fun (name, index) -> + Meta (Printf.sprintf "\t.stabs \"%s:1\",128,0,0,-%d" name (stack_offset index)) + ) + scope.names + in + names @ + (if names = [] then [] else [Meta (Printf.sprintf "\t.stabn 192,0,0,%s-%s" scope.blab f)]) @ + (List.flatten @@ List.map stabs_scope scope.subs) @ + (if names = [] then [] else [Meta (Printf.sprintf "\t.stabn 224,0,0,%s-%s" scope.elab f)]) + in + let name = + if f.[0] = 'L' then String.sub f 1 (String.length f - 1) else f + in + env#assert_empty_stack; + let has_closure = closure <> [] in + let env = env#enter f nargs nlocals has_closure in + env, [Meta (Printf.sprintf "\t.type %s, @function" name)] @ + (if f = "main" + then [] + else + [Meta (Printf.sprintf "\t.stabs \"%s:F1\",36,0,0,%s" name f)] @ + (List.mapi (fun i a -> Meta (Printf.sprintf "\t.stabs \"%s:p1\",160,0,0,%d" a ((i*4) + 8))) args) @ + (List.flatten @@ List.map stabs_scope scopes) + ) + @ + [Meta "\t.cfi_startproc"] @ + (if has_closure then [Push edx] else []) @ + (if f = cmd#topname + then + [Mov (M "_init", eax); + Binop ("test", eax, eax); + CJmp ("z", "_continue"); + Ret; + Label "_continue"; + Mov (L 1, M "_init"); + ] + else [] + ) @ + [Push ebp; + Meta ("\t.cfi_def_cfa_offset\t" ^ if has_closure then "12" else "8"); + Meta ("\t.cfi_offset 5, -" ^ if has_closure then "12" else "8"); + Mov (esp, ebp); + Meta "\t.cfi_def_cfa_register\t5"; + Binop ("-", M ("$" ^ env#lsize), esp); + Mov (esp, edi); + Mov (M "$filler", esi); + Mov (M ("$" ^ (env#allocated_size)), ecx); + Repmovsl + ] @ + (if f = "main" + then [Call "__gc_init"; Push (I (12, ebp)); Push (I (8, ebp)); Call "set_args"; Binop ("+", L 8, esp)] + else [] + ) @ + (if f = cmd#topname + then List.map (fun i -> Call ("init" ^ i)) (List.filter (fun i -> i <> "Std") imports) + else [] + ) + + | END -> + let x, env = env#pop in + env#assert_empty_stack; + let name = env#fname in + env#leave, [ + Mov (x, eax); (*!!*) + Label env#epilogue; + Mov (ebp, esp); + Pop ebp; + ] @ + env#rest_closure @ + (if name = "main" then [Binop ("^", eax, eax)] else []) @ + [Meta "\t.cfi_restore\t5"; + Meta "\t.cfi_def_cfa\t4, 4"; + Ret; + Meta "\t.cfi_endproc"; + 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); + Meta (Printf.sprintf "\t.size %s, .-%s" name name); + ] + + | RET -> + let x = env#peek in + env, [Mov (x, eax); Jmp env#epilogue] + + | ELEM -> call env ".elem" 2 false + + | CALL (f, n, tail) -> call env f n tail + + | CALLC (n, tail) -> callc env n tail + + | SEXP (t, n) -> + let s, env = env#allocate in + let env, code = call env ".sexp" (n+1) false in + env, [Mov (L (box (env#hash t)), s)] @ code + + | DROP -> + snd env#pop, [] + + | DUP -> + let x = env#peek in + let s, env = env#allocate in + env, mov x s + + | SWAP -> + let x, y = env#peek2 in + env, [Push x; Push y; Pop x; Pop y] + + | TAG (t, n) -> + let s1, env = env#allocate in + let s2, env = env#allocate in + let env, code = call env ".tag" 3 false in + env, [Mov (L (box (env#hash t)), s1); Mov (L (box n), s2)] @ code + + | ARRAY n -> + let s, env = env#allocate in + let env, code = call env ".array_patt" 2 false in + env, [Mov (L (box n), s)] @ code + + | PATT StrCmp -> call env ".string_patt" 2 false + + | PATT patt -> + call env + (match patt with + | Boxed -> ".boxed_patt" + | UnBoxed -> ".unboxed_patt" + | Array -> ".array_tag_patt" + | String -> ".string_tag_patt" + | Sexp -> ".sexp_tag_patt" + | Closure -> ".closure_tag_patt" + ) 1 false + | LINE (line) -> + env#gen_line line + + | FAIL ((line, col), value) -> + let v, env = if value then env#peek, env else env#pop in + let s, env = env#string cmd#get_infile in + env, [Push (L (box col)); Push (L (box line)); Push (M ("$" ^ s)); Push v; Call "Bmatch_failure"; Binop ("+", L (4 * word_size), esp)] + + | i -> + invalid_arg (Printf.sprintf "invalid SM insn: %s\n" (GT.show(insn) i)) + in + let env'', code'' = compile' env' scode' in + env'', [Meta (Printf.sprintf "# %s / % s" (GT.show(SM.insn) instr) stack)] @ code' @ code'' + in + compile' env code + +(* A set of strings *) +module S = Set.Make (String) + +(* A map indexed by strings *) +module M = Map.Make (String) + +(* Environment implementation *) +class env prg = + let chars = "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'" in + let make_assoc l i = List.combine l (List.init (List.length l) (fun x -> x + i)) in + let rec assoc x = function [] -> raise Not_found | l :: ls -> try List.assoc x l with Not_found -> assoc x ls in + object (self) + inherit SM.indexer prg + val globals = S.empty (* a set of global variables *) + val stringm = M.empty (* a string map *) + val scount = 0 (* string count *) + val stack_slots = 0 (* maximal number of stack positions *) + + val static_size = 0 (* static data size *) + val stack = [] (* symbolic stack *) + val nargs = 0 (* number of function arguments *) + val locals = [] (* function local variables *) + val fname = "" (* function name *) + val stackmap = M.empty (* labels to stack map *) + val barrier = false (* barrier condition *) + val max_locals_size = 0 + val has_closure = false + val publics = S.empty + val externs = S.empty + val nlabels = 0 + val first_line = true + + method publics = S.elements publics + + method register_public name = {< publics = S.add name publics >} + method register_extern name = {< externs = S.add name externs >} + + method max_locals_size = max_locals_size + + method has_closure = has_closure + + method save_closure = + if has_closure then [Push edx] else [] + + method rest_closure = + if has_closure then [Pop edx] else [] + + method reload_closure = + if has_closure then [Mov (C (*S 0*), edx)] else [] + + method fname = fname + + method leave = + if stack_slots > max_locals_size + then {< max_locals_size = stack_slots >} + else self + + method show_stack = + GT.show(list) (GT.show(opnd)) stack + + method print_locals = + Printf.printf "LOCALS: size = %d\n" static_size; + List.iter + (fun l -> + Printf.printf "("; + List.iter (fun (a, i) -> Printf.printf "%s=%d " a i) l; + Printf.printf ")\n" + ) locals; + Printf.printf "END LOCALS\n" + + (* Assert empty stack *) + method assert_empty_stack = assert (stack = []) + + (* check barrier condition *) + method is_barrier = barrier + + (* set barrier *) + method set_barrier = {< barrier = true >} + + (* drop barrier *) + method drop_barrier = {< barrier = false >} + + (* drop stack *) + method drop_stack = {< stack = [] >} + + (* associates a stack to a label *) + method set_stack l = (*Printf.printf "Setting stack for %s\n" l;*) + {< stackmap = M.add l stack stackmap >} + + (* retrieves a stack for a label *) + method retrieve_stack l = (*Printf.printf "Retrieving stack for %s\n" l;*) + try {< stack = M.find l stackmap >} with Not_found -> self + + (* checks if there is a stack for a label *) + method has_stack l = (*Printf.printf "Retrieving stack for %s\n" l;*) + M.mem l stackmap + + (* gets a name for a global variable *) + method loc x = + match x with + | Value.Global name -> M ("global_" ^ name) + | Value.Fun name -> M ("$" ^ name) + | Value.Local i -> S i + | Value.Arg i -> S (- (i + if has_closure then 2 else 1)) + | Value.Access i -> I (word_size * (i+1), edx) + + (* 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 + in + x, {< stack_slots = max n stack_slots; stack = x::stack >} + + (* pushes an operand to the symbolic stack *) + method push y = {< stack = y::stack >} + + (* pops one operand from the symbolic stack *) + method pop = let x::stack' = stack in x, {< stack = stack' >} + + (* pops two operands from the symbolic stack *) + method pop2 = let x::y::stack' = stack in x, y, {< stack = stack' >} + + (* peeks the top of the stack (the stack does not change) *) + method peek = List.hd stack + + (* peeks two topmost values from the stack (the stack itself does not change) *) + method peek2 = let x::y::_ = stack in x, y + + (* tag hash: gets a hash for a string tag *) + method hash tag = + let h = Pervasives.ref 0 in + for i = 0 to min (String.length tag - 1) 4 do + h := (!h lsl 6) lor (String.index chars tag.[i]) + done; + !h + + (* registers a variable in the environment *) + method variable x = + match x with + | Value.Global name -> {< globals = S.add ("global_" ^ name) globals >} + | _ -> self + + (* registers a string constant *) + method string x = + let escape x = + let n = String.length x in + let buf = Buffer.create (n*2) in + let rec iterate i = + if i < n + then ( + (match x.[i] with + | '"' -> Buffer.add_string buf "\\\"" + | '\n' -> Buffer.add_string buf "\n" + | '\t' -> Buffer.add_string buf "\t" + | c -> Buffer.add_char buf c + ); + iterate (i+1) + ) + in + iterate 0; + Buffer.contents buf + in + let x = escape x in + try M.find x stringm, self + with Not_found -> + let y = Printf.sprintf "string_%d" scount in + let m = M.add x y stringm in + y, {< scount = scount + 1; stringm = m>} + + (* gets number of arguments in the current function *) + method nargs = nargs + + (* gets all global variables *) + method globals = S.elements (S.diff globals externs) + + (* gets all string definitions *) + method strings = M.bindings stringm + + (* gets a number of stack positions allocated *) + method allocated = stack_slots + + method allocated_size = Printf.sprintf "LS%s_SIZE" fname + + (* enters a function *) + method enter f nargs nlocals has_closure = + {< nargs = nargs; static_size = nlocals; stack_slots = nlocals; stack = []; fname = f; has_closure = has_closure; first_line = true >} + + (* returns a label for the epilogue *) + method epilogue = Printf.sprintf "L%s_epilogue" fname + + (* returns a name for local size meta-symbol *) + method lsize = Printf.sprintf "L%s_SIZE" fname + + (* returns a list of live registers *) + method live_registers depth = + let rec inner d acc = function + | [] -> acc + | (R _ as r)::tl -> inner (d+1) (if d >= depth then (r::acc) else acc) tl + | _::tl -> inner (d+1) acc tl + in + inner 0 [] stack + + (* generate a line number information for current function *) + method gen_line line = + let lab = Printf.sprintf ".L%d" nlabels in + {< nlabels = nlabels + 1; first_line = false >}, + if fname = "main" + then + [Meta (Printf.sprintf "\t.stabn 68,0,%d,%s" line lab); Label lab] + else + (if first_line then [Meta (Printf.sprintf "\t.stabn 68,0,%d,0" line)] else []) @ + [Meta (Printf.sprintf "\t.stabn 68,0,%d,%s-%s" line lab fname); Label lab] + + end + +(* Generates an assembler text for a program: first compiles the program into + the stack code, then generates x86 assember code, then prints the assembler file +*) +let genasm cmd prog = + let sm = SM.compile cmd prog in + let env, code = compile cmd (new env sm) (fst (fst prog)) sm in + let globals = + List.map (fun s -> Meta (Printf.sprintf "\t.globl\t%s" s)) env#publics + in + let data = [Meta "\t.data"] @ + (List.map (fun (s, v) -> Meta (Printf.sprintf "%s:\t.string\t\"%s\"" v s)) env#strings) @ + [Meta "_init:\t.int 0"; + Meta "\t.section custom_data,\"aw\",@progbits"; + Meta (Printf.sprintf "filler:\t.fill\t%d, 4, 1" env#max_locals_size)] @ + (List.concat @@ + List.map + (fun s -> [Meta (Printf.sprintf "\t.stabs \"%s:S1\",40,0,0,%s" (String.sub s (String.length "global_") (String.length s - String.length "global_")) s); + Meta (Printf.sprintf "%s:\t.int\t1" s)]) + env#globals + ) + in + let asm = Buffer.create 1024 in + List.iter + (fun i -> Buffer.add_string asm (Printf.sprintf "%s\n" @@ show i)) + ([Meta (Printf.sprintf "\t.file \"%s\"" cmd#get_absolute_infile); + Meta (Printf.sprintf "\t.stabs \"%s\",100,0,0,.Ltext" cmd#get_absolute_infile)] @ + globals @ + data @ + [Meta "\t.text"; Label ".Ltext"; Meta "\t.stabs \"data:t1=r1;0;4294967295;\",128,0,0,0"] @ + code); + Buffer.contents asm + +let get_std_path () = + match Sys.getenv_opt "LAMA" with + | Some s -> s + | None -> Stdpath.path + +(* Builds a program: generates the assembler file and compiles it with the gcc toolchain *) +let build cmd prog = + let find_objects imports paths = + let module S = Set.Make (String) in + let rec iterate acc s = function + | [] -> acc + | import::imports -> + if S.mem import s + then iterate acc s imports + else + let path, intfs = Interface.find import paths in + iterate + ((Filename.concat path (import ^ ".o")) :: acc) + (S.add import s) + ((List.map (function `Import name -> name | _ -> invalid_arg "must not happen") @@ + List.filter (function `Import _ -> true | _ -> false) intfs) @ + imports) + in + iterate [] (S.add "Std" S.empty) imports + in + cmd#dump_file "s" (genasm cmd prog); + cmd#dump_file "i" (Interface.gen prog); + let inc = get_std_path () in + match cmd#get_mode with + | `Default -> + let objs = find_objects (fst @@ fst prog) cmd#get_include_paths in + let buf = Buffer.create 255 in + List.iter (fun o -> Buffer.add_string buf o; Buffer.add_string buf " ") objs; + let gcc_cmdline = Printf.sprintf "gcc %s -m32 %s %s.s %s %s/runtime.a" cmd#get_debug cmd#get_output_option cmd#basename (Buffer.contents buf) inc in + Sys.command gcc_cmdline + | `Compile -> + Sys.command (Printf.sprintf "gcc %s -m32 -c %s.s" cmd#get_debug cmd#basename) + | _ -> invalid_arg "must not happen"