mirror of
https://github.com/ProgramSnail/Lama.git
synced 2025-12-06 06:48:48 +00:00
Final commit
This commit is contained in:
Roman Venediktov
parent
b532e90ea0
commit
db296f5259
7 changed files with 57 additions and 34 deletions
3
.github/workflows/blank.yml
vendored
3
.github/workflows/blank.yml
vendored
|
|
@ -13,6 +13,7 @@ jobs:
|
|||
matrix:
|
||||
os:
|
||||
- ubuntu-latest
|
||||
- macos-latest-xl
|
||||
ocaml-compiler:
|
||||
- 4.13.1
|
||||
|
||||
|
|
@ -33,5 +34,3 @@ jobs:
|
|||
- run: eval $(opam env)
|
||||
- run: opam exec -- make
|
||||
- run: opam exec -- make regression-all
|
||||
- run: opam exec -- make unit_tests
|
||||
- run: opam exec -- make negative_scenarios_tests
|
||||
|
|
|
|||
2
Makefile
2
Makefile
|
|
@ -20,7 +20,7 @@ remake_runtime:
|
|||
$(MAKE) -C runtime clean
|
||||
$(MAKE) -C runtime all
|
||||
|
||||
copy_to_build: all
|
||||
copy_to_build: all remake_runtime
|
||||
mkdir -p $(BUILDDIR)
|
||||
cp runtime/Std.i runtime/runtime.a stdlib/* $(BUILDDIR)
|
||||
|
||||
|
|
|
|||
12
runtime/gc.c
12
runtime/gc.c
|
|
@ -59,8 +59,10 @@ void *alloc (size_t size) {
|
|||
#endif
|
||||
void *p = gc_alloc_on_existing_heap(size);
|
||||
if (!p) {
|
||||
fprintf(stderr, "Garbage collection is not implemented yet.\n");
|
||||
exit(149);
|
||||
// not enough place in the heap, need to perform GC cycle
|
||||
p = gc_alloc(size);
|
||||
// p = gc_alloc(size);
|
||||
}
|
||||
return p;
|
||||
}
|
||||
|
|
@ -223,7 +225,7 @@ void *gc_alloc (size_t size) {
|
|||
}
|
||||
|
||||
static void gc_root_scan_stack () {
|
||||
for (size_t *p = (size_t *)(__gc_stack_top + 4); p < (size_t *)__gc_stack_bottom; ++p) {
|
||||
for (size_t *p = (size_t *)(__gc_stack_top + sizeof(size_t)); p < (size_t *)__gc_stack_bottom; ++p) {
|
||||
gc_test_and_mark_root((size_t **)p);
|
||||
}
|
||||
}
|
||||
|
|
@ -438,7 +440,7 @@ void update_references (memory_chunk *old_heap) {
|
|||
heap_next_obj_iterator(&it);
|
||||
}
|
||||
// fix pointers from stack
|
||||
scan_and_fix_region(old_heap, (void *)__gc_stack_top + 4, (void *)__gc_stack_bottom + 4);
|
||||
scan_and_fix_region(old_heap, (void *)__gc_stack_top + sizeof(size_t), (void *)__gc_stack_bottom + sizeof(size_t));
|
||||
|
||||
// fix pointers from extra_roots
|
||||
scan_and_fix_region_roots(old_heap);
|
||||
|
|
@ -571,7 +573,7 @@ void __init (void) {
|
|||
srandom(time(NULL));
|
||||
|
||||
heap.begin = mmap(
|
||||
NULL, space_size, PROT_READ | PROT_WRITE, MAP_PRIVATE | MAP_ANONYMOUS | MAP_32BIT, -1, 0);
|
||||
NULL, space_size, PROT_READ | PROT_WRITE, MAP_PRIVATE | MAP_ANONYMOUS, -1, 0);
|
||||
if (heap.begin == MAP_FAILED) {
|
||||
perror("ERROR: __init: mmap failed\n");
|
||||
exit(1);
|
||||
|
|
@ -684,7 +686,7 @@ void set_forward_address (void *obj, size_t addr) {
|
|||
|
||||
bool is_marked (void *obj) {
|
||||
data *d = TO_DATA(obj);
|
||||
int mark_bit = GET_MARK_BIT(d->forward_address);
|
||||
aint mark_bit = GET_MARK_BIT(d->forward_address);
|
||||
return mark_bit;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -41,7 +41,7 @@
|
|||
// # define MINIMUM_HEAP_CAPACITY (8)
|
||||
// #else
|
||||
// # define MINIMUM_HEAP_CAPACITY (1 << 2)
|
||||
#define MINIMUM_HEAP_CAPACITY (1 << 26)
|
||||
#define MINIMUM_HEAP_CAPACITY (1 << 30)
|
||||
// #endif
|
||||
|
||||
#include <stdbool.h>
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
.section .text
|
||||
|
||||
.global Lprintf
|
||||
.extern printf
|
||||
.extern Bprintf
|
||||
|
||||
.global Lfprintf
|
||||
.extern fprintf
|
||||
.extern Bfprintf
|
||||
|
||||
.global Lsprintf
|
||||
.extern Bsprintf
|
||||
|
|
@ -26,22 +26,22 @@ Lprintf:
|
|||
movq %rsp, %rax
|
||||
# rdi --- format string
|
||||
# r11 --- number of arguments except format string
|
||||
loop:
|
||||
Lprintf_loop:
|
||||
movq $0, %r12
|
||||
cmpq %r11, %r12
|
||||
jz continue
|
||||
jz Lprintf_continue
|
||||
|
||||
decq %r11
|
||||
movq (%rax), %r10
|
||||
testq $1, %r10
|
||||
jz jmpCont
|
||||
jz Lprintf_loop_end
|
||||
# unbox value
|
||||
sarq %r10
|
||||
movq %r10, (%rax)
|
||||
jmpCont:
|
||||
Lprintf_loop_end:
|
||||
addq $8, %rax
|
||||
jmp loop
|
||||
continue:
|
||||
jmp Lprintf_loop
|
||||
Lprintf_continue:
|
||||
popq %rsi
|
||||
popq %rdx
|
||||
popq %rcx
|
||||
|
|
@ -49,7 +49,7 @@ continue:
|
|||
popq %r9
|
||||
# restore return address
|
||||
pushq %r14
|
||||
jmp printf
|
||||
jmp Bprintf
|
||||
|
||||
Lfprintf:
|
||||
# save return address
|
||||
|
|
@ -85,7 +85,7 @@ Lfprintf_continue:
|
|||
popq %r9
|
||||
# restore return address
|
||||
pushq %r14
|
||||
jmp fprintf
|
||||
jmp Bfprintf
|
||||
|
||||
Lsprintf:
|
||||
# save return address
|
||||
|
|
|
|||
|
|
@ -82,7 +82,7 @@ extern aint LcompareTags (void *p, void *q) {
|
|||
if (TAG(pd->data_header) == SEXP_TAG && TAG(qd->data_header) == SEXP_TAG) {
|
||||
return BOX((TO_SEXP(p)->tag) - (TO_SEXP(q)->tag));
|
||||
} else {
|
||||
failure("not a sexpr in compareTags: %d, %d\n", TAG(pd->data_header), TAG(qd->data_header));
|
||||
failure("not a sexpr in compareTags: %ld, %ld\n", TAG(pd->data_header), TAG(qd->data_header));
|
||||
}
|
||||
// dead code
|
||||
return 0;
|
||||
|
|
@ -319,7 +319,7 @@ static void printValue (void *p) {
|
|||
data *a = (data *)BOX(NULL);
|
||||
aint i = BOX(0);
|
||||
if (UNBOXED(p)) {
|
||||
printStringBuf("%d", UNBOX(p));
|
||||
printStringBuf("%ld", UNBOX(p));
|
||||
} else {
|
||||
if (!is_valid_heap_pointer(p)) {
|
||||
printStringBuf("0x%x", p);
|
||||
|
|
@ -468,7 +468,7 @@ extern void *Lsubstring (void *subj, aint p, aint l) {
|
|||
return r->contents;
|
||||
}
|
||||
|
||||
failure("substring: index out of bounds (position=%d, length=%d, subject length=%d)",
|
||||
failure("substring: index out of bounds (position=%ld, length=%ld, subject length=%ld)",
|
||||
pp,
|
||||
ll,
|
||||
LEN(d->data_header));
|
||||
|
|
@ -497,7 +497,7 @@ extern aint LregexpMatch (struct re_pattern_buffer *b, char *s, aint pos) {
|
|||
|
||||
res = re_match(b, s, LEN(TO_DATA(s)->data_header), UNBOX(pos), 0);
|
||||
|
||||
/* printf ("regexpMatch %x: %s, res=%d\n", b, s+UNBOX(pos), res); */
|
||||
/* printf ("regexpMatch %x: %s, res=%ld\n", b, s+UNBOX(pos), res); */
|
||||
|
||||
if (res) { return BOX(res); }
|
||||
|
||||
|
|
@ -537,7 +537,7 @@ void *Lclone (void *p) {
|
|||
res = (void *)obj->contents;
|
||||
break;
|
||||
|
||||
default: failure("invalid data_header %d in clone *****\n", t);
|
||||
default: failure("invalid data_header %ld in clone *****\n", t);
|
||||
}
|
||||
pop_extra_root(&p);
|
||||
|
||||
|
|
@ -587,7 +587,7 @@ aint inner_hash (aint depth, auint acc, void *p) {
|
|||
break;
|
||||
}
|
||||
|
||||
default: failure("invalid data_header %d in hash *****\n", t);
|
||||
default: failure("invalid data_header %ld in hash *****\n", t);
|
||||
}
|
||||
|
||||
for (; i < l; i++) acc = inner_hash(depth + 1, acc, ((void **)a->contents)[i]);
|
||||
|
|
@ -598,7 +598,7 @@ aint inner_hash (aint depth, auint acc, void *p) {
|
|||
|
||||
extern void *LstringInt (char *b) {
|
||||
aint n;
|
||||
sscanf(b, "%d", &n);
|
||||
sscanf(b, "%ld", &n);
|
||||
return (void *)BOX(n);
|
||||
}
|
||||
|
||||
|
|
@ -659,7 +659,7 @@ extern aint Lcompare (void *p, void *q) {
|
|||
break;
|
||||
}
|
||||
|
||||
default: failure("invalid data_header %d in compare *****\n", ta);
|
||||
default: failure("invalid data_header %ld in compare *****\n", ta);
|
||||
}
|
||||
|
||||
for (; i < la; i++) {
|
||||
|
|
@ -971,7 +971,7 @@ extern void *Bsta (void *v, aint i, void *x) {
|
|||
extern void Bmatch_failure (void *v, char *fname, aint line, aint col) {
|
||||
createStringBuf();
|
||||
printValue(v);
|
||||
failure("match failure at %s:%d:%d, value '%s'\n",
|
||||
failure("match failure at %s:%ld:%ld, value '%s'\n",
|
||||
fname,
|
||||
UNBOX(line),
|
||||
UNBOX(col),
|
||||
|
|
@ -1026,11 +1026,6 @@ extern void *LgetEnv (char *var) {
|
|||
|
||||
extern aint Lsystem (char *cmd) { return BOX(system(cmd)); }
|
||||
|
||||
extern void Lfailure (char *s, ...);
|
||||
extern void Lprintf (char *s, ...);
|
||||
extern void *Lsprintf (char *fmt, ...);
|
||||
extern void Lfprintf (FILE *f, char *s, ...);
|
||||
|
||||
#ifndef X86_64
|
||||
// In X86_64 we are not able to modify va_arg
|
||||
|
||||
|
|
@ -1106,6 +1101,7 @@ extern void Lfprintf (FILE *f, char *s, ...) {
|
|||
|
||||
if (vfprintf(f, s, args) < 0) { failure("fprintf (...): %s\n", strerror(errno)); }
|
||||
}
|
||||
|
||||
#else
|
||||
|
||||
extern void *Bsprintf (char *fmt, ...) {
|
||||
|
|
@ -1133,6 +1129,29 @@ extern void *Bsprintf (char *fmt, ...) {
|
|||
return s;
|
||||
}
|
||||
|
||||
extern void Bprintf (char *s, ...) {
|
||||
va_list args; // = (va_list)BOX(NULL);
|
||||
|
||||
ASSERT_STRING("printf:1", s);
|
||||
|
||||
va_start(args, s);
|
||||
|
||||
if (vprintf(s, args) < 0) { failure("fprintf (...): %s\n", strerror(errno)); }
|
||||
|
||||
fflush(stdout);
|
||||
}
|
||||
|
||||
extern void Bfprintf (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);
|
||||
|
||||
if (vfprintf(f, s, args) < 0) { failure("fprintf (...): %s\n", strerror(errno)); }
|
||||
}
|
||||
|
||||
#endif
|
||||
|
||||
extern FILE *Lfopen (char *f, char *m) {
|
||||
|
|
@ -1261,7 +1280,7 @@ extern aint Lwrite (aint n) {
|
|||
extern aint Lrandom (aint n) {
|
||||
ASSERT_UNBOXED("Lrandom, 0", n);
|
||||
|
||||
if (UNBOX(n) <= 0) { failure("invalid range in random: %d\n", UNBOX(n)); }
|
||||
if (UNBOX(n) <= 0) { failure("invalid range in random: %ld\n", UNBOX(n)); }
|
||||
|
||||
return BOX(random() % UNBOX(n));
|
||||
}
|
||||
|
|
|
|||
|
|
@ -387,6 +387,9 @@ let compile_call env ?fname nargs tail =
|
|||
let allowed_function =
|
||||
match fname with
|
||||
| Some "Lprintf" -> false
|
||||
| Some "Lsprintf" -> false
|
||||
| Some "Lfprintf" -> false
|
||||
| Some "Lfailure" -> false
|
||||
| Some fname -> not (fname.[0] = '.')
|
||||
| None -> true
|
||||
in
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue