diff --git a/runtime/Makefile b/runtime/Makefile index 5d41a1014..9786a5c52 100644 --- a/runtime/Makefile +++ b/runtime/Makefile @@ -1,15 +1,22 @@ +CC=gcc -all: gc_runtime.o gc.o runtime.o +all: gc_runtime.o gc.o runtime.o test.o ar rc runtime.a gc_runtime.o runtime.o gc.o +test.o: gc.o gc_runtime.o runtime.o virt_stack.o test_main.c test_util.s + $(CC) -o test.o -g2 -fstack-protector-all -m32 gc.o gc_runtime.o virt_stack.o runtime.o test_main.c test_util.s + +virt_stack.o: virt_stack.h virt_stack.c + $(CC) -g2 -fstack-protector-all -m32 -c virt_stack.c + gc.o: gc.c gc.h - $(CC) -g -fstack-protector-all -m32 -c gc.c + $(CC) -g2 -fstack-protector-all -m32 -c gc.c gc_runtime.o: gc_runtime.s - $(CC) -g -fstack-protector-all -m32 -c gc_runtime.s + $(CC) -g2 -fstack-protector-all -m32 -c gc_runtime.s runtime.o: runtime.c runtime.h - $(CC) -g -fstack-protector-all -m32 -c runtime.c + $(CC) -g2 -fstack-protector-all -m32 -c runtime.c clean: $(RM) *.a *.o *~ diff --git a/runtime/gc.c b/runtime/gc.c index 8c26c1ed4..8c47146ea 100644 --- a/runtime/gc.c +++ b/runtime/gc.c @@ -1,30 +1,46 @@ # define _GNU_SOURCE 1 +#include "gc.h" +#include "runtime_common.h" + #include #include #include #include #include -#include "gc.h" -#include "runtime_common.h" +#include + +#ifdef DEBUG_VERSION +#include +#endif + #ifndef DEBUG_VERSION static const size_t INIT_HEAP_SIZE = 1 << 18; #else static const size_t INIT_HEAP_SIZE = 8; #endif -static const size_t SIZE_T_CHARS = sizeof(size_t)/sizeof(char); #ifdef DEBUG_VERSION -static const size_t cur_id = 1; +size_t cur_id = 0; #endif static extra_roots_pool extra_roots; extern size_t __gc_stack_top, __gc_stack_bottom; +#ifndef DEBUG_VERSION +extern const size_t __start_custom_data, __stop_custom_data; +#endif +#ifdef DEBUG_VERSION +memory_chunk heap; +#else static memory_chunk heap; +#endif -void* alloc(size_t size) { +void *alloc(size_t size) { +#ifdef DEBUG_VERSION + ++cur_id; +#endif size = BYTES_TO_WORDS(size); void *p = gc_alloc_on_existing_heap(size); if (!p) { @@ -34,55 +50,79 @@ void* alloc(size_t size) { return p; } -void* gc_alloc_on_existing_heap(size_t size) { - if (heap.current + size < heap.end) { +void *gc_alloc_on_existing_heap(size_t size) { + if (heap.current + size <= heap.end) { void *p = (void *) heap.current; heap.current += size; + memset(p, 0, size * sizeof(size_t)); return p; } return NULL; } -void* gc_alloc(size_t size) { - // mark phase - // TODO: add extra roots and static area scan - __gc_root_scan_stack(); +void *gc_alloc(size_t size) { + mark_phase(); - // compact phase - compact(size); + compact_phase(size); return gc_alloc_on_existing_heap(size); } -void compact(size_t additional_size) { +void mark_phase(void) { + __gc_root_scan_stack(); + scan_extra_roots(); +#ifndef DEBUG_VERSION + scan_global_area(); +#endif +} + +void compact_phase(size_t additional_size) { size_t live_size = compute_locations(); size_t next_heap_size = MAX(live_size * EXTRA_ROOM_HEAP_COEFFICIENT + additional_size, MINIMUM_HEAP_CAPACITY); + size_t next_heap_pseudo_size = MAX(next_heap_size, heap.size); // this is weird but here is why it happens: + // if we allocate too little heap right now, we may loose access to some alive objects + // however, after we physically relocate all of our objects we will shrink allocated memory if it is possible - memory_chunk new_memory; - new_memory.begin = mremap( + memory_chunk old_heap = heap; + heap.begin = mremap( + heap.begin, + WORDS_TO_BYTES(heap.size), + WORDS_TO_BYTES(next_heap_pseudo_size), + MREMAP_MAYMOVE + ); + if (heap.begin == MAP_FAILED) { + perror("ERROR: compact_phase: mremap failed\n"); + exit(1); + } + heap.end = heap.begin + next_heap_pseudo_size; + heap.size = next_heap_pseudo_size; + heap.current = heap.begin + (old_heap.current - old_heap.begin); + + update_references(&old_heap); + physically_relocate(&old_heap); + + // shrink it if possible, otherwise this code won'test_small_tree_compaction do anything, in both cases references will remain valid + heap.begin = mremap( heap.begin, WORDS_TO_BYTES(heap.size), WORDS_TO_BYTES(next_heap_size), - MREMAP_MAYMOVE - ); - if (new_memory.begin == MAP_FAILED) { - perror ("ERROR: compact: mremap failed\n"); - exit (1); + 0 // in this case we don't set MREMAP_MAYMOVE because it shouldn'test_small_tree_compaction move :) + ); + if (heap.begin == MAP_FAILED) { + perror("ERROR: compact_phase: mremap failed\n"); + exit(1); } - new_memory.end = new_memory.begin + next_heap_size; - new_memory.size = next_heap_size; - new_memory.current = new_memory.begin + live_size; - - update_references(&new_memory); - physically_relocate(&new_memory); + heap.end = heap.begin + next_heap_size; + heap.size = next_heap_size; + heap.current = heap.begin + live_size; } size_t compute_locations() { - size_t* free_ptr = heap.begin; + size_t *free_ptr = heap.begin; heap_iterator scan_iter = heap_begin_iterator(); - for (; heap_is_done_iterator(&scan_iter); heap_next_obj_iterator(&scan_iter)) { + for (; !heap_is_done_iterator(&scan_iter); heap_next_obj_iterator(&scan_iter)) { void *header_ptr = scan_iter.current; void *obj_content = get_object_content_ptr(header_ptr); size_t sz = BYTES_TO_WORDS(obj_size_header_ptr(header_ptr)); @@ -94,32 +134,66 @@ size_t compute_locations() { } // it will return number of words - return scan_iter.current - heap.begin; + return free_ptr - heap.begin; } -// TODO: fix pointers on stack and in static area -void update_references(memory_chunk *next_memory) { - heap_iterator it = heap_begin_iterator(); - while (!heap_is_done_iterator(&it)) { - for ( - obj_field_iterator field_iter = ptr_field_begin_iterator(it.current); - !field_is_done_iterator(&field_iter); - obj_next_ptr_field_iterator(&field_iter) +void scan_and_fix_region(memory_chunk *old_heap, void *start, void *end) { + for (size_t *ptr = (size_t *) start; ptr < (size_t *) end; ++ptr) { + size_t ptr_value = *ptr; + // this can't be expressed via is_valid_heap_pointer, because this pointer may point area corresponding to the old heap + if (is_valid_pointer((size_t *) ptr_value) + && (size_t) old_heap->begin <= ptr_value + && ptr_value < (size_t) old_heap->current ) { - void *field_obj_content = *(void **) field_iter.cur_field; // TODO: create iterator method 'dereference', so that code would be a bit more readable - // important, we calculate new_addr very carefully here, because objects may relocate to another memory chunk - size_t *new_addr = next_memory->begin + ((size_t *) get_forward_address(field_obj_content) - heap.begin); - // update field reference to point to new_addr - // since, we want fields to point to actual content, we need to add this extra content_offset - // because forward_address itself is pointer to object header - size_t content_offset = get_header_size(get_type_row_ptr(field_obj_content)); - * (void **) field_iter.cur_field = new_addr + content_offset; + void *obj_ptr = (void*) heap.begin + ((void *) ptr_value - (void *) old_heap->begin); + void *new_addr = (void*) heap.begin + ((void *) get_forward_address(obj_ptr) - (void *) old_heap->begin); + size_t content_offset = get_header_size(get_type_row_ptr(obj_ptr)); + *(void **) ptr = new_addr + content_offset; } - heap_next_obj_iterator(&it); } } -void physically_relocate(memory_chunk *next_memory) { +void update_references(memory_chunk *old_heap) { + heap_iterator it = heap_begin_iterator(); + while (!heap_is_done_iterator(&it)) { + if (is_marked(get_object_content_ptr(it.current))) { + for ( + obj_field_iterator field_iter = ptr_field_begin_iterator(it.current); + !field_is_done_iterator(&field_iter); + obj_next_ptr_field_iterator(&field_iter) + ) { + + // this pointer should also be modified according to old_heap->begin + void *field_obj_content_addr = (void *) heap.begin + (*(void **) field_iter.cur_field - (void *) old_heap->begin); // TODO: vstack_create iterator method 'dereference', so that code would be a bit more readable + // important, we calculate new_addr very carefully here, because objects may relocate to another memory chunk + void *new_addr = + heap.begin + ((size_t *) get_forward_address(field_obj_content_addr) - (size_t *) old_heap->begin); + // update field reference to point to new_addr + // since, we want fields to point to an actual content, we need to add this extra content_offset + // because forward_address itself is a pointer to the object's header + size_t content_offset = get_header_size(get_type_row_ptr(field_obj_content_addr)); + if (!is_valid_heap_pointer((void *) (new_addr + content_offset))) { + fprintf(stderr, "ur: incorrect pointer assignment: on object with id %d", TO_DATA(get_object_content_ptr(it.current))->id); + exit(1); + } + *(void **) field_iter.cur_field = new_addr + content_offset; + } + } + heap_next_obj_iterator(&it); + } + // fix pointers from stack + scan_and_fix_region(old_heap, (void*) __gc_stack_top, (void*) __gc_stack_bottom); + + // fix pointers from extra_roots + scan_and_fix_region(old_heap, (void*) extra_roots.roots, (size_t*) extra_roots.roots + extra_roots.current_free); + +#ifndef DEBUG_VERSION + // fix pointers from static area + scan_and_fix_region(old_heap, (void*) &__start_custom_data, (void*) &__stop_custom_data); +#endif +} + +void physically_relocate(memory_chunk *old_heap) { heap_iterator from_iter = heap_begin_iterator(); while (!heap_is_done_iterator(&from_iter)) { @@ -127,16 +201,20 @@ void physically_relocate(memory_chunk *next_memory) { if (is_marked(obj)) { // Move the object from its old location to its new location relative to // the heap's (possibly new) location, 'to' points to future object header - void* to = next_memory->begin + ((size_t *) get_forward_address(obj) - heap.begin); - memmove(to, from_iter.current, BYTES_TO_WORDS(obj_size_header_ptr(obj))); - unmark_object(to + ((size_t *) obj - from_iter.current)); + size_t *to = heap.begin + ((size_t *) get_forward_address(obj) - (size_t *) old_heap->begin); + memmove(to, from_iter.current, obj_size_header_ptr(from_iter.current)); + unmark_object(get_object_content_ptr(to)); } heap_next_obj_iterator(&from_iter); } } bool is_valid_heap_pointer(const size_t *p) { - return !UNBOXED(p) && (size_t) heap.begin <= (size_t) p && (size_t) p < (size_t) heap.end; + return !UNBOXED(p) && (size_t) heap.begin <= (size_t) p && (size_t) p < (size_t) heap.current; +} + +bool is_valid_pointer(const size_t *p) { + return !UNBOXED(p); } void mark(void *obj) { @@ -152,54 +230,83 @@ void mark(void *obj) { obj_field_iterator ptr_field_it = ptr_field_begin_iterator(header_ptr); !field_is_done_iterator(&ptr_field_it); obj_next_ptr_field_iterator(&ptr_field_it) - ) { - mark(ptr_field_it.cur_field); + ) { + mark(* (void **) ptr_field_it.cur_field); } } -extern void gc_test_and_mark_root(size_t ** root) { - mark((void*) *root); +void scan_extra_roots(void) { + for (int i = 0; i < extra_roots.current_free; ++i) { + // this dereferencing is safe since runtime is pushing correct pointers into extra_roots + mark(*extra_roots.roots[i]); + } } -extern void __init (void) { +#ifndef DEBUG_VERSION +void scan_global_area(void) { + // __start_custom_data is pointing to beginning of global area, thus all dereferencings are safe + for (const size_t *ptr = &__start_custom_data; ptr < &__stop_custom_data; ++ptr) { + mark(*(void **)ptr); + } +} +#endif + +extern void gc_test_and_mark_root(size_t **root) { + mark((void *) *root); +} + +extern void __init(void) { size_t space_size = INIT_HEAP_SIZE * sizeof(size_t); - srandom (time (NULL)); + srandom(time(NULL)); - heap.begin = mmap (NULL, space_size, PROT_READ | PROT_WRITE, - MAP_PRIVATE | MAP_ANONYMOUS | MAP_32BIT, -1, 0); + heap.begin = mmap(NULL, space_size, PROT_READ | PROT_WRITE, + MAP_PRIVATE | MAP_ANONYMOUS | MAP_32BIT, -1, 0); if (heap.begin == MAP_FAILED) { - perror ("ERROR: __init: mmap failed\n"); - exit (1); + perror("ERROR: __init: mmap failed\n"); + exit(1); } - heap.end = heap.begin + INIT_HEAP_SIZE; - heap.size = INIT_HEAP_SIZE; - heap.current = heap.begin; + heap.end = heap.begin + INIT_HEAP_SIZE; + heap.size = INIT_HEAP_SIZE; + heap.current = heap.begin; clear_extra_roots(); } -void clear_extra_roots (void) { +extern void __shutdown(void) { + munmap(heap.begin, heap.size); +#ifdef DEBUG_VERSION + cur_id = 0; +#endif + heap.begin = NULL; + heap.end = NULL; + heap.size = 0; + heap.current = NULL; + __gc_stack_top = 0; + __gc_stack_bottom = 0; +} + +void clear_extra_roots(void) { extra_roots.current_free = 0; } -void push_extra_root (void ** p) { +void push_extra_root(void **p) { if (extra_roots.current_free >= MAX_EXTRA_ROOTS_NUMBER) { - perror ("ERROR: push_extra_roots: extra_roots_pool overflow"); - exit (1); + perror("ERROR: push_extra_roots: extra_roots_pool overflow"); + exit(1); } extra_roots.roots[extra_roots.current_free] = p; extra_roots.current_free++; } -void pop_extra_root (void ** p) { +void pop_extra_root(void **p) { if (extra_roots.current_free == 0) { - perror ("ERROR: pop_extra_root: extra_roots are empty"); - exit (1); + perror("ERROR: pop_extra_root: extra_roots are empty"); + exit(1); } extra_roots.current_free--; if (extra_roots.roots[extra_roots.current_free] != p) { - perror ("ERROR: pop_extra_root: stack invariant violation"); - exit (1); + perror("ERROR: pop_extra_root: stack invariant violation"); + exit(1); } } @@ -207,18 +314,19 @@ void pop_extra_root (void ** p) { #ifdef DEBUG_VERSION -void objects_snapshot(void *objects_ptr, size_t objects_cnt) { - size_t *ids_ptr = (size_t *) objects_ptr; +size_t objects_snapshot(int *object_ids_buf, size_t object_ids_buf_size) { + size_t *ids_ptr = (size_t *) object_ids_buf; size_t i = 0; for ( heap_iterator it = heap_begin_iterator(); - !heap_is_done_iterator(&it) && i < objects_cnt; - heap_next_obj_iterator(&it) - ) { + !heap_is_done_iterator(&it) && i < object_ids_buf_size; + heap_next_obj_iterator(&it), ++i + ) { void *header_ptr = it.current; data *d = TO_DATA(get_object_content_ptr(header_ptr)); ids_ptr[i] = d->id; } + return i; } void set_stack(size_t stack_top, size_t stack_bottom) { @@ -241,7 +349,7 @@ size_t get_forward_address(void *obj) { return GET_FORWARD_ADDRESS(d->forward_address); } -size_t set_forward_address(void *obj, size_t addr) { +void set_forward_address(void *obj, size_t addr) { data *d = TO_DATA(obj); SET_FORWARD_ADDRESS(d->forward_address, addr); } @@ -263,7 +371,7 @@ void unmark_object(void *obj) { } heap_iterator heap_begin_iterator() { - heap_iterator it = { .current=heap.begin }; + heap_iterator it = {.current=heap.begin}; return it; } @@ -296,8 +404,13 @@ lama_type get_type_header_ptr(void *ptr) { case SEXP_TAG: return SEXP; default: - perror ("ERROR: get_type_header_ptr: unknown object header"); - exit (1); +#ifdef DEBUG_VERSION + fprintf(stderr, "ERROR: get_type_header_ptr: unknown object header, cur_id=%d", cur_id); + raise(SIGINT); // only for debug purposes +#else + perror("ERROR: get_type_header_ptr: unknown object header"); +#endif + exit(1); } } @@ -318,8 +431,11 @@ size_t obj_size_header_ptr(void *ptr) { case SEXP: return sexp_size(len); default: - perror ("ERROR: obj_size_header_ptr: unknown object header"); - exit (1); + perror("ERROR: obj_size_header_ptr: unknown object header"); +#ifdef DEBUG_VERSION + raise(SIGINT); // only for debug purposes +#endif + exit(1); } } @@ -336,18 +452,22 @@ size_t closure_size(size_t sz) { return get_header_size(CLOSURE) + MEMBER_SIZE * sz; } -size_t sexp_size(size_t sz) { - return get_header_size(SEXP) + MEMBER_SIZE * sz; +size_t sexp_size(size_t members) { + return get_header_size(SEXP) + MEMBER_SIZE * members; } obj_field_iterator field_begin_iterator(void *obj) { - lama_type type = get_type_row_ptr(obj); - obj_field_iterator it = { .type=type, .obj_ptr=get_obj_header_ptr(obj, type), .cur_field=obj }; + lama_type type = get_type_header_ptr(obj); + obj_field_iterator it = {.type=type, .obj_ptr=obj, .cur_field=get_object_content_ptr(obj)}; // since string doesn't have any actual fields we set cur_field to the end of object if (type == STRING) { it.cur_field = get_end_of_obj(it.obj_ptr); } + // skip first member which is basically pointer to the code + if (type == CLOSURE) { + it.cur_field += MEMBER_SIZE; + } return it; } @@ -357,7 +477,7 @@ obj_field_iterator ptr_field_begin_iterator(void *obj) { if (field_is_done_iterator(&it)) { return it; } - if (is_valid_heap_pointer(it.cur_field)) { + if (is_valid_pointer(*(size_t **) it.cur_field)) { return it; } obj_next_ptr_field_iterator(&it); @@ -371,23 +491,23 @@ void obj_next_field_iterator(obj_field_iterator *it) { void obj_next_ptr_field_iterator(obj_field_iterator *it) { do { obj_next_field_iterator(it); - } while (!field_is_done_iterator(it) && !is_valid_heap_pointer(it->cur_field)); + } while (!field_is_done_iterator(it) && !is_valid_pointer(*(size_t **) it->cur_field)); } bool field_is_done_iterator(obj_field_iterator *it) { return it->cur_field >= get_end_of_obj(it->obj_ptr); } -void* get_obj_header_ptr(void *ptr, lama_type type) { +void *get_obj_header_ptr(void *ptr, lama_type type) { return ptr - get_header_size(type); } -void* get_object_content_ptr(void *header_ptr) { +void *get_object_content_ptr(void *header_ptr) { lama_type type = get_type_header_ptr(header_ptr); return header_ptr + get_header_size(type); } -void* get_end_of_obj(void *header_ptr) { +void *get_end_of_obj(void *header_ptr) { return header_ptr + obj_size_header_ptr(header_ptr); } @@ -400,8 +520,43 @@ size_t get_header_size(lama_type type) { case SEXP: return SEXP_ONLY_HEADER_SZ + DATA_HEADER_SZ; default: - perror ("ERROR: get_header_size: unknown object type"); - exit (1); + perror("ERROR: get_header_size: unknown object type"); +#ifdef DEBUG_VERSION + raise(SIGINT); // only for debug purposes +#endif + exit(1); } } +void *alloc_string(int len) { + data *obj = alloc(string_size(len)); + obj->data_header = STRING_TAG | (len << 3); + obj->id = cur_id; + obj->forward_address = 0; + return obj; +} + +void *alloc_array(int len) { + data *obj = alloc(array_size(len)); + obj->data_header = ARRAY_TAG | (len << 3); + obj->id = cur_id; + obj->forward_address = 0; + return obj; +} + +void *alloc_sexp(int members) { + sexp *obj = alloc(sexp_size(members)); + obj->sexp_header = obj->contents.data_header = SEXP_TAG | (members << 3); + obj->contents.id = cur_id; + obj->contents.forward_address = 0; + obj->tag = 0; + return obj; +} + +void *alloc_closure(int captured) { + data *obj = alloc(closure_size(captured)); + obj->data_header = CLOSURE_TAG | (captured << 3); + obj->id = cur_id; + obj->forward_address = 0; + return obj; +} diff --git a/runtime/gc.h b/runtime/gc.h index c58068e34..d245f912a 100644 --- a/runtime/gc.h +++ b/runtime/gc.h @@ -1,22 +1,26 @@ #ifndef __LAMA_GC__ #define __LAMA_GC__ +// this flag makes GC behavior a bit different for testing purposes. +#define DEBUG_VERSION + # define GET_MARK_BIT(x) (((int) (x)) & 1) # define SET_MARK_BIT(x) (x = (((int) (x)) | 1)) # define RESET_MARK_BIT(x) (x = (((int) (x)) & (~1))) -# define GET_FORWARD_ADDRESS(x) (((int) (x)) & (~1)) // since last bit is used as mark-bit and due to correct alignment we can expect that last bit doesn't influence address (it should always be zero) -# define SET_FORWARD_ADDRESS(x, addr) (x = (((int) (x)) | ((int) (addr)))) +# define GET_FORWARD_ADDRESS(x) (((size_t) (x)) & (~1)) // since last bit is used as mark-bit and due to correct alignment we can expect that last bit doesn'test_small_tree_compaction influence address (it should always be zero) +# define SET_FORWARD_ADDRESS(x, addr) (x = (GET_MARK_BIT(x) | ((int) (addr)))) # define EXTRA_ROOM_HEAP_COEFFICIENT 2 // TODO: tune this parameter +#ifdef DEBUG_VERSION # define MINIMUM_HEAP_CAPACITY (1<<8) // TODO: tune this parameter +#else +# define MINIMUM_HEAP_CAPACITY (1<<8) // TODO: tune this parameter +#endif #include #include #include "runtime_common.h" -// this flag makes GC behavior a bit different for testing purposes. -#define DEBUG_VERSION - typedef enum { ARRAY, CLOSURE, STRING, SEXP } lama_type; typedef struct { @@ -53,27 +57,37 @@ void* gc_alloc(size_t); // takes number of words as a parameter void *gc_alloc_on_existing_heap(size_t); -void collect(); - -// specific for mark-and-compact gc +// specific for mark-and-compact_phase gc void mark(void *obj); +void mark_phase(void); +// written in ASM, scans stack for pointers to the heap and starts marking process +extern void __gc_root_scan_stack(void); // TODO: write without ASM, since it is absolutely not necessary +// marks each pointer from extra roots +void scan_extra_roots(void); +#ifndef DEBUG_VERSION +// marks each valid pointer from global area +void scan_global_area(void); +#endif // takes number of words that are required to be allocated somewhere on the heap -void compact(size_t additional_size); +void compact_phase(size_t additional_size); // specific for Lisp-2 algorithm size_t compute_locations(); void update_references(memory_chunk *); void physically_relocate(memory_chunk *); - // written in ASM extern void __gc_init (void); // MANDATORY TO CALL BEFORE ANY INTERACTION WITH GC (apart from cases where we are working with virtual stack as happens in tests) +extern void __init (void); // should be called before interaction with GC in case of using in tests with virtual stack, otherwise it is automatically invoked by __gc_init +extern void __shutdown (void); // mostly useful for tests but basically you want to call this in case you want to deallocate all object allocated via GC +// written in ASM extern void __pre_gc (void); +// written in ASM extern void __post_gc (void); -extern void __gc_root_scan_stack(void); // TODO: write without ASM, since it is absolutely not necessary // invoked from ASM extern void gc_test_and_mark_root(size_t ** root); inline bool is_valid_heap_pointer(const size_t *); +inline bool is_valid_pointer(const size_t *); void clear_extra_roots (void); @@ -86,8 +100,11 @@ void pop_extra_root (void ** p); #ifdef DEBUG_VERSION -// test-only function, these pointer parameters are just a fancy way to return two values at a time -void objects_snapshot(void *objects_ptr, size_t objects_cnt); +// makes a snapshot of current objects in heap (both alive and dead), writes these ids to object_ids_buf, +// returns number of ids dumped +// object_ids_buf is pointer to area preallocated by user for dumping ids of objects in heap +// object_ids_buf_size is in WORDS, NOT BYTES +size_t objects_snapshot(int *object_ids_buf, size_t object_ids_buf_size); // essential function to mock program stack void set_stack(size_t stack_top, size_t stack_bottom); @@ -100,11 +117,15 @@ void set_extra_roots(size_t extra_roots_size, void** extra_roots_ptr); /* Utility functions */ +// accepts pointer to the start of the region and to the end of the region +// scans it and if it meets a pointer, it should be modified in according to forward address +void scan_and_fix_region(memory_chunk *old_heap, void *start, void *end); + // takes a pointer to an object content as an argument, returns forwarding address size_t get_forward_address(void *obj); // takes a pointer to an object content as an argument, sets forwarding address to value 'addr' -size_t set_forward_address(void *obj, size_t addr); +void set_forward_address(void *obj, size_t addr); // takes a pointer to an object content as an argument, returns whether this object was marked as live bool is_marked(void *obj); @@ -139,8 +160,8 @@ size_t string_size(size_t len); // TODO: ask if it is actually so? number of captured elements is actually sz-1 and 1 extra word is code ptr? // returns number of bytes that are required to allocate closure with 'sz-1' captured values (header included) size_t closure_size(size_t sz); -// returns number of bytes that are required to allocate s-expression with 'sz' fields (header included) -size_t sexp_size(size_t sz); +// returns number of bytes that are required to allocate s-expression with 'members' fields (header included) +size_t sexp_size(size_t members); // returns an iterator over object fields, obj is ptr to object header // (in case of s-exp, it is mandatory that obj ptr is very beginning of the object, @@ -161,4 +182,9 @@ void* get_obj_header_ptr(void *ptr, lama_type type); void* get_object_content_ptr(void *header_ptr); void* get_end_of_obj(void *header_ptr); +void *alloc_string(int len); +void *alloc_array(int len); +void *alloc_sexp(int members); +void *alloc_closure(int captured); + #endif \ No newline at end of file diff --git a/runtime/gc_runtime.s b/runtime/gc_runtime.s index 5b80dd1ce..df8e28d58 100644 --- a/runtime/gc_runtime.s +++ b/runtime/gc_runtime.s @@ -17,7 +17,8 @@ __gc_stack_top: .long 0 .extern gc_test_and_copy_root .text -__gc_init: movl %ebp, __gc_stack_bottom +__gc_init: + movl %ebp, __gc_stack_bottom addl $4, __gc_stack_bottom call __init ret @@ -60,7 +61,9 @@ __gc_root_scan_stack: pushl %ebx pushl %edx movl __gc_stack_top, %eax - jmp next + // jmp next + cmpl %eax, __gc_stack_bottom + jb returnn loop: movl (%eax), %ebx @@ -106,7 +109,7 @@ gc_run_t: next: addl $4, %eax cmpl %eax, __gc_stack_bottom - jne loop + jnb loop returnn: movl $0, %eax popl %edx diff --git a/runtime/runtime.c b/runtime/runtime.c index baa10b309..5eb28ca8e 100644 --- a/runtime/runtime.c +++ b/runtime/runtime.c @@ -6,19 +6,13 @@ # include "runtime_common.h" # include "gc.h" -# define __ENABLE_GC__ +# define __ENABLE_GC__ # ifndef __ENABLE_GC__ # define alloc malloc # endif //# define DEBUG_PRINT 1 -/* GC memory_chunk structure and data; declared here in order to allow debug print */ -static memory_chunk from_space; -static memory_chunk to_space; -size_t *current; -/* end */ - # ifdef __ENABLE_GC__ /* GC extern invariant for built-in functions */ @@ -37,25 +31,25 @@ void __post_gc_subst () {} /* end */ static void vfailure (char *s, va_list args) { - fprintf (stderr, "*** FAILURE: "); - vfprintf (stderr, s, args); // vprintf (char *, va_list) <-> printf (char *, ...) - exit (255); + 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); - } + 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) \ @@ -66,7 +60,7 @@ void Lassert (void *f, char *s, ...) { do if (!UNBOXED(x) && TAG(TO_DATA(x)->data_header) \ != STRING_TAG) failure ("string value expected in %s\n", memo); while (0) -extern void* alloc (size_t); +//extern void* alloc (size_t); extern void* Bsexp (int n, ...); extern int LtagHash (char*); @@ -74,162 +68,158 @@ void *global_sysargs; // Gets a raw data_header extern int LkindOf (void *p) { - if (UNBOXED(p)) return UNBOXED_TAG; - - return TAG(TO_DATA(p)->data_header); + if (UNBOXED(p)) return UNBOXED_TAG; + + return TAG(TO_DATA(p)->data_header); } // Compare sexprs tags extern int LcompareTags (void *p, void *q) { - data *pd, *qd; - - ASSERT_BOXED ("compareTags, 0", p); - ASSERT_BOXED ("compareTags, 1", q); + data *pd, *qd; - pd = TO_DATA(p); - qd = TO_DATA(q); + ASSERT_BOXED ("compareTags, 0", p); + ASSERT_BOXED ("compareTags, 1", q); - if (TAG(pd->data_header) == SEXP_TAG && TAG(qd->data_header) == SEXP_TAG) { - return - #ifndef DEBUG_PRINT - BOX((TO_SEXP(p)->tag) - (TO_SEXP(q)->tag)); - #else - BOX((GET_SEXP_TAG(TO_SEXP(p)->data_header)) - (GET_SEXP_TAG(TO_SEXP(p)->data_header))); - #endif - } - else failure ("not a sexpr in compareTags: %d, %d\n", TAG(pd->data_header), TAG(qd->data_header)); - - return 0; // never happens + pd = TO_DATA(p); + qd = TO_DATA(q); + + if (TAG(pd->data_header) == SEXP_TAG && TAG(qd->data_header) == SEXP_TAG) { + return +#ifndef DEBUG_PRINT + BOX((TO_SEXP(p)->tag) - (TO_SEXP(q)->tag)); +#else + BOX((GET_SEXP_TAG(TO_SEXP(p)->data_header)) - (GET_SEXP_TAG(TO_SEXP(p)->data_header))); +#endif + } + else failure ("not a sexpr in compareTags: %d, %d\n", TAG(pd->data_header), TAG(qd->data_header)); + + return 0; // never happens } // Functional synonym for built-in operator ":"; void* Ls__Infix_58 (void *p, void *q) { - void *res; - - __pre_gc (); + void *res; - 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); + __pre_gc (); - __post_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); - return res; + __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); + ASSERT_UNBOXED("captured !!:1", p); + ASSERT_UNBOXED("captured !!:2", q); - return BOX(UNBOX(p) || UNBOX(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); + ASSERT_UNBOXED("captured &&:1", p); + ASSERT_UNBOXED("captured &&:2", q); - return BOX(UNBOX(p) && UNBOX(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); + 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); + ASSERT_UNBOXED("captured !=:1", p); + ASSERT_UNBOXED("captured !=:2", q); - return BOX(UNBOX(p) != UNBOX(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); + ASSERT_UNBOXED("captured <=:1", p); + ASSERT_UNBOXED("captured <=:2", q); - return BOX(UNBOX(p) <= UNBOX(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); + ASSERT_UNBOXED("captured <:1", p); + ASSERT_UNBOXED("captured <:2", q); - return BOX(UNBOX(p) < UNBOX(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); + ASSERT_UNBOXED("captured >=:1", p); + ASSERT_UNBOXED("captured >=:2", q); - return BOX(UNBOX(p) >= UNBOX(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); + ASSERT_UNBOXED("captured >:1", p); + ASSERT_UNBOXED("captured >:2", q); - return BOX(UNBOX(p) > UNBOX(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); + ASSERT_UNBOXED("captured +:1", p); + ASSERT_UNBOXED("captured +:2", q); - return BOX(UNBOX(p) + UNBOX(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)); - } + if (UNBOXED(p)) { + ASSERT_UNBOXED("captured -:2", q); + return BOX(UNBOX(p) - UNBOX(q)); + } - ASSERT_BOXED("captured -:1", q); - return BOX(p - 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); + ASSERT_UNBOXED("captured *:1", p); + ASSERT_UNBOXED("captured *:2", q); - return BOX(UNBOX(p) * UNBOX(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); + ASSERT_UNBOXED("captured /:1", p); + ASSERT_UNBOXED("captured /:2", q); - return BOX(UNBOX(p) / UNBOX(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); + ASSERT_UNBOXED("captured %:1", p); + ASSERT_UNBOXED("captured %:2", q); - return BOX(UNBOX(p) % UNBOX(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->data_header)); + ASSERT_BOXED(".length", p); + return BOX(obj_size_row_ptr(p)); } static char* chars = "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'"; @@ -237,63 +227,63 @@ static char* chars = "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234 extern char* de_hash (int); extern int LtagHash (char *s) { - char *p; - int h = 0, limit = 0; - - p = s; + char *p; + int h = 0, limit = 0; - while (*p && limit++ <= 4) { - char *q = chars; - int pos = 0; - - for (; *q && *q != *p; q++, pos++); + p = s; - if (*q) h = (h << 6) | pos; - else failure ("tagHash: character not found: %c\n", *p); + while (*p && limit++ <= 4) { + char *q = chars; + int pos = 0; - p++; - } + for (; *q && *q != *p; q++, pos++); - if (strcmp (s, de_hash (h)) != 0) { - failure ("%s <-> %s\n", s, de_hash(h)); - } - - return BOX(h); + if (*q) h = (h << 6) | pos; + else failure ("tagHash: character not found: %c\n", *p); + + p++; + } + + if (strcmp (s, de_hash (h)) != 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]; + // 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 (); + indent++; print_indent (); printf ("de_hash: data_header: %d\n", n); fflush (stdout); #endif - - *p-- = 0; - while (n != 0) { + *p-- = 0; + + while (n != 0) { #ifdef DEBUG_PRINT - print_indent (); + print_indent (); printf ("char: %c\n", chars [n & 0x003F]); fflush (stdout); #endif - *p-- = chars [n & 0x003F]; - n = n >> 6; - } + *p-- = chars [n & 0x003F]; + n = n >> 6; + } #ifdef DEBUG_PRINT - indent--; + indent--; #endif - - return ++p; + + return ++p; } typedef struct { - char *contents; - int ptr; - int len; + char *contents; + int ptr; + int len; } StringBuf; static StringBuf stringBuf; @@ -301,1146 +291,1148 @@ 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; + 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); + free (stringBuf.contents); } static void extendStringBuf () { - int len = stringBuf.len << 1; + int len = stringBuf.len << 1; - stringBuf.contents = (char*) realloc (stringBuf.contents, len); - stringBuf.len = len; + 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; + int written = 0, + rest = 0; + char *buf = (char*) BOX(NULL); + va_list vsnargs; - written = vsnprintf (buf, rest, fmt, vsnargs); + again: + va_copy (vsnargs, args); - va_end(vsnargs); - - if (written >= rest) { - extendStringBuf (); - goto again; - } + buf = &stringBuf.contents[stringBuf.ptr]; + rest = stringBuf.len - stringBuf.ptr; - stringBuf.ptr += written; + 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_list args; - va_start (args, fmt); - vprintStringBuf (fmt, 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); + 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; + } - switch (TAG(a->data_header)) { - case STRING_TAG: - printStringBuf ("\"%s\"", a->contents); - break; + a = TO_DATA(p); - case CLOSURE_TAG: - printStringBuf ("data_header); i++) { - if (i) printValue ((void*)((int*) a->contents)[i]); - else printStringBuf ("0x%x", (void*)((int*) a->contents)[i]); - - if (i != LEN(a->data_header) - 1) printStringBuf (", "); - } - printStringBuf (">"); - break; - - case ARRAY_TAG: - printStringBuf ("["); - for (i = 0; i < LEN(a->data_header); i++) { - printValue ((void*)((int*) a->contents)[i]); - if (i != LEN(a->data_header) - 1) printStringBuf (", "); - } - printStringBuf ("]"); - break; - - case SEXP_TAG: { + switch (TAG(a->data_header)) { + case STRING_TAG: + printStringBuf ("\"%s\"", a->contents); + break; + + case CLOSURE_TAG: + printStringBuf ("data_header); i++) { + if (i) printValue ((void*)((int*) a->contents)[i]); + else printStringBuf ("0x%x", (void*)((int*) a->contents)[i]); + if (i != LEN(a->data_header) - 1) printStringBuf (", "); + } + printStringBuf (">"); + break; + + case ARRAY_TAG: + printStringBuf ("["); + for (i = 0; i < LEN(a->data_header); i++) { + printValue ((void*)((int*) a->contents)[i]); + if (i != LEN(a->data_header) - 1) printStringBuf (", "); + } + printStringBuf ("]"); + break; + + case SEXP_TAG: { #ifndef DEBUG_PRINT - char * tag = de_hash (TO_SEXP(p)->tag); + char * tag = de_hash (TO_SEXP(p)->tag); #else - char * data_header = de_hash (GET_SEXP_TAG(TO_SEXP(p)->data_header)); -#endif - - if (strcmp (tag, "cons") == 0) { - data *b = a; - - printStringBuf ("{"); + char * data_header = de_hash (GET_SEXP_TAG(TO_SEXP(p)->data_header)); +#endif - while (LEN(a->data_header)) { - 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->data_header)) { - printStringBuf (" ("); - for (i = 0; i < LEN(a->data_header); i++) { - printValue ((void*)((int*) a->contents)[i]); - if (i != LEN(a->data_header) - 1) printStringBuf (", "); - } - printStringBuf (")"); - } - } - } - break; + if (strcmp (tag, "cons") == 0) { + data *b = a; + printStringBuf ("{"); + while (LEN(a->data_header)) { + 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->data_header)) { + printStringBuf (" ("); + for (i = 0; i < LEN(a->data_header); i++) { + printValue ((void*)((int*) a->contents)[i]); + if (i != LEN(a->data_header) - 1) printStringBuf (", "); + } + printStringBuf (")"); + } + } + } + break; - default: - printStringBuf ("*** invalid data_header: 0x%x ***", TAG(a->data_header)); + default: + printStringBuf ("*** invalid data_header: 0x%x ***", TAG(a->data_header)); + } } - } } static void stringcat (void *p) { - data *a; - int i; - - if (UNBOXED(p)) ; - else { - a = TO_DATA(p); + data *a; + int i; - switch (TAG(a->data_header)) { - case STRING_TAG: - printStringBuf ("%s", a->contents); - break; - - case SEXP_TAG: { + if (UNBOXED(p)) ; + else { + a = TO_DATA(p); + + switch (TAG(a->data_header)) { + case STRING_TAG: + printStringBuf ("%s", a->contents); + break; + + case SEXP_TAG: { #ifndef DEBUG_PRINT - char * tag = de_hash (TO_SEXP(p)->tag); + char * tag = de_hash (TO_SEXP(p)->tag); #else - char * data_header = de_hash (GET_SEXP_TAG(TO_SEXP(p)->data_header)); -#endif - if (strcmp (tag, "cons") == 0) { - data *b = a; - - while (LEN(a->data_header)) { - 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 data_header: %s ***", tag); - } - break; + char * data_header = de_hash (GET_SEXP_TAG(TO_SEXP(p)->data_header)); +#endif + if (strcmp (tag, "cons") == 0) { + data *b = a; - default: - printStringBuf ("*** invalid data_header: 0x%x ***", TAG(a->data_header)); + while (LEN(a->data_header)) { + 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 data_header: %s ***", tag); + } + break; + + default: + printStringBuf ("*** invalid data_header: 0x%x ***", TAG(a->data_header)); + } } - } } extern int Luppercase (void *v) { - ASSERT_UNBOXED("Luppercase:1", v); - return BOX(toupper ((int) UNBOX(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))); + 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; + 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->data_header); + ASSERT_STRING("matchSubString:1", subj); + ASSERT_STRING("matchSubString:2", patt); + ASSERT_UNBOXED("matchSubString:3", pos); - if (n + UNBOX(pos) > LEN(s->data_header)) - return BOX(0); - - return BOX(strncmp (subj + UNBOX(pos), patt, n) == 0); + n = LEN (p->data_header); + + if (n + UNBOX(pos) > LEN(s->data_header)) + 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); + 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->data_header)) { - data *r; - - __pre_gc (); + ASSERT_STRING("substring:1", subj); + ASSERT_UNBOXED("substring:2", p); + ASSERT_UNBOXED("substring:3", l); - push_extra_root (&subj); - r = (data*) alloc (ll + 1 + sizeof (int)); - pop_extra_root (&subj); + if (pp + ll <= LEN(d->data_header)) { + data *r; - r->data_header = STRING_TAG | (ll << 3); + __pre_gc (); - strncpy (r->contents, (char*) subj + pp, ll); - - __post_gc (); + push_extra_root (&subj); + r = (data*) alloc_string(ll); + pop_extra_root (&subj); - return r->contents; - } - - failure ("substring: index out of bounds (position=%d, length=%d, \ + 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->data_header)); } extern struct re_pattern_buffer *Lregexp (char *regexp) { - regex_t *b = (regex_t*) malloc (sizeof (regex_t)); + 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)); - }; + /* printf ("regexp: %s,\test_small_tree_compaction%x\n", regexp, b); */ - return 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); + int res; - res = re_match (b, s, LEN(TO_DATA(s)->data_header), UNBOX(pos), 0); + ASSERT_BOXED("regexpMatch:1", b); + ASSERT_STRING("regexpMatch:2", s); + ASSERT_UNBOXED("regexpMatch:3", 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); */ + + if (res) { + return BOX (res); + } - /* 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; + data *obj; + sexp *sobj; + void* res; + int n; #ifdef DEBUG_PRINT - register int * ebp asm ("ebp"); + 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->data_header), l = LEN(a->data_header); + __pre_gc (); - push_extra_root (&p); - switch (t) { - case STRING_TAG: + if (UNBOXED(p)) return p; + else { + data *a = TO_DATA(p); + int t = TAG(a->data_header), l = LEN(a->data_header); + + push_extra_root (&p); + switch (t) { + case STRING_TAG: #ifdef DEBUG_PRINT - print_indent (); + print_indent (); printf ("Lclone: string1 &p=%p p=%p\n", &p, p); fflush (stdout); #endif - res = Bstring (TO_DATA(p)->contents); + res = Bstring (TO_DATA(p)->contents); #ifdef DEBUG_PRINT - print_indent (); + print_indent (); printf ("Lclone: string2 %p %p\n", &p, p); fflush (stdout); #endif - break; + break; - case ARRAY_TAG: - case CLOSURE_TAG: + case ARRAY_TAG: #ifdef DEBUG_PRINT - print_indent (); - printf ("Lclone: closure or array &p=%p p=%p ebp=%p\n", &p, p, ebp); fflush (stdout); + print_indent (); + printf ("Lclone: 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: + obj = (data *) alloc_array(l); + memcpy(obj, TO_DATA(p), array_size(l)); + res = (void *) obj->contents; + break; + case CLOSURE_TAG: #ifdef DEBUG_PRINT - print_indent (); printf ("Lclone: sexp\n"); fflush (stdout); + print_indent (); + printf ("Lclone: closure &p=%p p=%p ebp=%p\n", &p, p, ebp); 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 data_header %d in clone *****\n", t); + obj = (data *) alloc_closure(l); + memcpy (obj, TO_DATA(p), closure_size(l)); + res = (void*) (obj->contents); + break; + + case SEXP_TAG: +#ifdef DEBUG_PRINT + print_indent (); printf ("Lclone: sexp\n"); fflush (stdout); +#endif + sobj = (sexp*) alloc_sexp(l); + memcpy (sobj, TO_SEXP(p), sexp_size(l)); + res = (void*) sobj->contents.contents; + break; + + default: + failure ("invalid data_header %d in clone *****\n", t); + } + pop_extra_root (&p); } - pop_extra_root (&p); - } #ifdef DEBUG_PRINT - print_indent (); printf ("Lclone ends1\n"); fflush (stdout); + print_indent (); printf ("Lclone ends1\n"); fflush (stdout); #endif - __post_gc (); + __post_gc (); #ifdef DEBUG_PRINT - print_indent (); + print_indent (); printf ("Lclone ends2\n"); fflush (stdout); indent--; #endif - return res; + 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 (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->data_header), l = LEN(a->data_header), i; + 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->data_header), l = LEN(a->data_header), i; - acc = HASH_APPEND(acc, t); - acc = HASH_APPEND(acc, l); + acc = HASH_APPEND(acc, t); + acc = HASH_APPEND(acc, l); - switch (t) { - case STRING_TAG: { - char *p = a->contents; + switch (t) { + case STRING_TAG: { + char *p = a->contents; - while (*p) { - int n = (int) *p++; - acc = HASH_APPEND(acc, n); - } + 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; + return acc; + } - case SEXP_TAG: { + 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; + int ta = TO_SEXP(p)->tag; #else - int ta = GET_SEXP_TAG(TO_SEXP(p)->data_header); + int ta = GET_SEXP_TAG(TO_SEXP(p)->data_header); #endif - acc = HASH_APPEND(acc, ta); - i = 0; - break; + acc = HASH_APPEND(acc, ta); + i = 0; + break; + } + + default: + failure ("invalid data_header %d in hash *****\n", t); + } + + for (; icontents)[i]); + + return acc; } - - default: - failure ("invalid data_header %d in hash *****\n", t); - } - - for (; icontents)[i]); - - return acc; - } - else return HASH_APPEND(acc, p); + else return HASH_APPEND(acc, p); } extern void* LstringInt (char *b) { - int n; - sscanf (b, "%d", &n); - return (void*) BOX(n); + int n; + sscanf (b, "%d", &n); + return (void*) BOX(n); } extern int Lhash (void *p) { - return BOX(0x3fffff & inner_hash (0, 0, 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)); + if (UNBOXED(p)) { + if (UNBOXED(q)) { + return BOX (UNBOX(p) - UNBOX(q)); + } + + return -1; } - - return -1; - } - else if (~UNBOXED(q)) { - return BOX(p - q); - } - else BOX(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->data_header), tb = TAG(b->data_header); - int la = LEN(a->data_header), lb = LEN(b->data_header); - 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)->data_header), tb = GET_SEXP_TAG(TO_SEXP(q)->data_header); -#endif - COMPARE_AND_RETURN (ta, tb); - COMPARE_AND_RETURN (la, lb); - i = 0; - break; - } + if (p == q) return BOX(0); - default: - failure ("invalid data_header %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); + 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->data_header), tb = TAG(b->data_header); + int la = LEN(a->data_header), lb = LEN(b->data_header); + 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)->data_header), tb = GET_SEXP_TAG(TO_SEXP(q)->data_header); +#endif + COMPARE_AND_RETURN (ta, tb); + COMPARE_AND_RETURN (la, lb); + i = 0; + break; + } + + default: + failure ("invalid data_header %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); } - 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); + 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->data_header) == STRING_TAG) { - return (void*) BOX(a->contents[i]); - } - - return (void*) ((int*) a->contents)[i]; + ASSERT_BOXED(".elem:1", p); + ASSERT_UNBOXED(".elem:2", i); + + a = TO_DATA(p); + i = UNBOX(i); + + if (TAG(a->data_header) == STRING_TAG) { + return (void*) BOX(a->contents[i]); + } + + return (void*) ((int*) a->contents)[i]; } extern void* LmakeArray (int length) { - data *r; - int n, *p; + data *r; + int n, *p; - ASSERT_UNBOXED("makeArray:1", length); - - __pre_gc (); + ASSERT_UNBOXED("makeArray:1", length); - n = UNBOX(length); - r = (data*) alloc (sizeof(int) * (n+1)); + __pre_gc (); - r->data_header = ARRAY_TAG | (n << 3); + n = UNBOX(length); + r = (data*) alloc_array(n); - p = (int*) r->contents; - while (n--) *p++ = BOX(0); - - __post_gc (); + p = (int*) r->contents; + while (n--) *p++ = BOX(0); - return r->contents; + __post_gc (); + + return r->contents; } extern void* LmakeString (int length) { - int n = UNBOX(length); - data *r; + int n = UNBOX(length); + data *r; - ASSERT_UNBOXED("makeString", length); - - __pre_gc () ; - - r = (data*) alloc (n + 1 + sizeof (int)); + ASSERT_UNBOXED("makeString", length); - r->data_header = STRING_TAG | (n << 3); + __pre_gc () ; - __post_gc(); - - return r->contents; + r = (data*) alloc_string(n); // '\0' in the end of the string is taken into account + + __post_gc(); + + return r->contents; } extern void* Bstring (void *p) { - int n = strlen (p); - data *s = NULL; - - __pre_gc (); + int n = strlen (p); + void *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); + 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); + 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); + print_indent (); + printf ("\tBstring: call strncpy: %p %p %p %i\n", &p, p, s, n); fflush(stdout); #endif - strncpy ((char*)s, p, n + 1); + strncpy ((char*)s, p, n + 1); // +1 because of '\0' in the end of C-strings #ifdef DEBUG_PRINT - print_indent (); - printf ("\tBstring: ends\n"); fflush(stdout); - indent--; + print_indent (); + printf ("\tBstring: ends\n"); fflush(stdout); + indent--; #endif - __post_gc (); - - return s; + __post_gc (); + + return s; } extern void* Lstringcat (void *p) { - void *s; + void *s; - /* ASSERT_BOXED("stringcat", p); */ - - __pre_gc (); - - createStringBuf (); - stringcat (p); + /* ASSERT_BOXED("stringcat", p); */ - push_extra_root(&p); - s = Bstring (stringBuf.contents); - pop_extra_root(&p); - - deleteStringBuf (); + __pre_gc (); - __post_gc (); + createStringBuf (); + stringcat (p); - return s; + 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); + void *s = (void *) BOX (NULL); - __pre_gc () ; - - createStringBuf (); - printValue (p); + __pre_gc () ; - push_extra_root(&p); - s = Bstring (stringBuf.contents); - pop_extra_root(&p); - - deleteStringBuf (); + createStringBuf (); + printValue (p); - __post_gc (); + push_extra_root(&p); + s = Bstring (stringBuf.contents); + pop_extra_root(&p); - return s; + 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 (); + 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 (); + indent++; print_indent (); printf ("Bclosure: create n = %d\n", n); fflush(stdout); #endif - argss = (ebp + 12); - for (i = 0; idata_header = CLOSURE_TAG | ((n + 1) << 3); - ((void**) r->contents)[0] = entry; - - va_start(args, entry); - - for (i = 0; icontents)[i+1] = ai; - } - - va_end(args); + r = (data*) alloc_closure(n + 1); - __post_gc(); + ((void**) r->contents)[0] = entry; - argss--; - for (i = 0; icontents)[i+1] = ai; + } + + va_end(args); + + __post_gc(); + + argss--; + for (i = 0; icontents; + return r->contents; } extern void* Barray (int bn, ...) { - va_list args; - int i, ai; - data *r; - int n = UNBOX(bn); - - __pre_gc (); - + va_list args; + int i, ai; + data *r; + int n = UNBOX(bn); + + __pre_gc (); + #ifdef DEBUG_PRINT - indent++; print_indent (); + indent++; print_indent (); printf ("Barray: create n = %d\n", n); fflush(stdout); #endif - r = (data*) alloc (sizeof(int) * (n+1)); + r = (data*) alloc_array(n); - r->data_header = ARRAY_TAG | (n << 3); - - va_start(args, bn); - - for (i = 0; icontents)[i] = ai; - } - - va_end(args); + va_start(args, bn); - __post_gc(); + for (i = 0; icontents)[i] = ai; + } + + va_end(args); + + __post_gc(); #ifdef DEBUG_PRINT - indent--; + indent--; #endif - return r->contents; + 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); +#ifdef DEBUG_VERSION +extern memory_chunk heap; +#endif + +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 () ; - __pre_gc () ; - #ifdef DEBUG_PRINT - indent++; print_indent (); + 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->data_header = SEXP_TAG | ((n - 1) << 3); - - va_start(args, bn); - - for (i=0; icontents)[i] = ai; - } + int fields_cnt = n - 1; + r = (sexp*) alloc_sexp(fields_cnt); + d = &(r->contents); + r->tag = 0; - r->tag = UNBOX(va_arg(args, int)); + va_start(args, bn); -#ifdef DEBUG_PRINT - r->data_header = SEXP_TAG | ((r->data_header) << 3); - print_indent (); - printf("Bsexp: ends\n"); fflush (stdout); - indent--; + for (i=0; icontents)[i] = ai; + } - __post_gc(); + r->tag = UNBOX(va_arg(args, int)); - return d->contents; +#ifdef DEBUG_PRINT + r->data_header = SEXP_TAG | ((r->data_header) << 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); + data *r; + + if (UNBOXED(d)) return BOX(0); + else { + r = TO_DATA(d); #ifndef DEBUG_PRINT - return BOX(TAG(r->data_header) == SEXP_TAG && TO_SEXP(d)->tag == UNBOX(t) && LEN(r->data_header) == UNBOX(n)); + return BOX(TAG(r->data_header) == SEXP_TAG && TO_SEXP(d)->tag == UNBOX(t) && LEN(r->data_header) == UNBOX(n)); #else - return BOX(TAG(r->data_header) == SEXP_TAG && - GET_SEXP_TAG(TO_SEXP(d)->data_header) == UNBOX(t) && LEN(r->data_header) == UNBOX(n)); + return BOX(TAG(r->data_header) == SEXP_TAG && + GET_SEXP_TAG(TO_SEXP(d)->data_header) == UNBOX(test_small_tree_compaction) && LEN(r->data_header) == 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->data_header) == ARRAY_TAG && LEN(r->data_header) == UNBOX(n)); - } + data *r; + + if (UNBOXED(d)) return BOX(0); + else { + r = TO_DATA(d); + return BOX(TAG(r->data_header) == ARRAY_TAG && LEN(r->data_header) == 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); + data *rx = (data *) BOX (NULL), + *ry = (data *) BOX (NULL); - if (TAG(rx->data_header) != STRING_TAG) return BOX(0); - - return BOX(strcmp (rx->contents, ry->contents) == 0 ? 1 : 0); // TODO: ??? - } + ASSERT_STRING(".string_patt:2", y); + + if (UNBOXED(x)) return BOX(0); + else { + rx = TO_DATA(x); ry = TO_DATA(y); + + if (TAG(rx->data_header) != STRING_TAG) return BOX(0); + + return BOX(strcmp (rx->contents, ry->contents) == 0 ? 1 : 0); // TODO: ??? + } } extern int Bclosure_tag_patt (void *x) { - if (UNBOXED(x)) return BOX(0); - - return BOX(TAG(TO_DATA(x)->data_header) == CLOSURE_TAG); + if (UNBOXED(x)) return BOX(0); + + return BOX(TAG(TO_DATA(x)->data_header) == CLOSURE_TAG); } extern int Bboxed_patt (void *x) { - return BOX(UNBOXED(x) ? 0 : 1); + return BOX(UNBOXED(x) ? 0 : 1); } extern int Bunboxed_patt (void *x) { - return BOX(UNBOXED(x) ? 1 : 0); + 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)->data_header) == ARRAY_TAG); + if (UNBOXED(x)) return BOX(0); + + return BOX(TAG(TO_DATA(x)->data_header) == ARRAY_TAG); } extern int Bstring_tag_patt (void *x) { - if (UNBOXED(x)) return BOX(0); - - return BOX(TAG(TO_DATA(x)->data_header) == STRING_TAG); + if (UNBOXED(x)) return BOX(0); + + return BOX(TAG(TO_DATA(x)->data_header) == STRING_TAG); } extern int Bsexp_tag_patt (void *x) { - if (UNBOXED(x)) return BOX(0); - - return BOX(TAG(TO_DATA(x)->data_header) == SEXP_TAG); + if (UNBOXED(x)) return BOX(0); + + return BOX(TAG(TO_DATA(x)->data_header) == 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)->data_header) == STRING_TAG)((char*) x)[UNBOX(i)] = (char) UNBOX(v); - else ((int*) x)[UNBOX(i)] = (int) v; + if (UNBOXED(i)) { + ASSERT_BOXED(".sta:3", x); + // ASSERT_UNBOXED(".sta:2", i); + + if (TAG(TO_DATA(x)->data_header) == STRING_TAG)((char*) x)[UNBOX(i)] = (char) UNBOX(v); + else ((int*) x)[UNBOX(i)] = (int) v; + + return v; + } + + * (void**) x = 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++; + 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++; } - s++; - } } extern void Lfailure (char *s, ...) { - va_list args; - - va_start (args, s); - fix_unboxed (s, args); - vfailure (s, args); + 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); + 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); + 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); + ASSERT_STRING("++:1", a); + ASSERT_STRING("++:2", b); - __pre_gc () ; + da = TO_DATA(a); + db = TO_DATA(b); - push_extra_root (&a); - push_extra_root (&b); - d = (data *) alloc (sizeof(int) + LEN(da->data_header) + LEN(db->data_header) + 1); - pop_extra_root (&b); - pop_extra_root (&a); + __pre_gc () ; - da = TO_DATA(a); - db = TO_DATA(b); - - d->data_header = STRING_TAG | ((LEN(da->data_header) + LEN(db->data_header)) << 3); + push_extra_root (&a); + push_extra_root (&b); + d = alloc_string(LEN(da->data_header) + LEN(db->data_header)); + pop_extra_root (&b); + pop_extra_root (&a); - strncpy (d->contents , da->contents, LEN(da->data_header)); - strncpy (d->contents + LEN(da->data_header), db->contents, LEN(db->data_header)); - - d->contents[LEN(da->data_header) + LEN(db->data_header)] = 0; + da = TO_DATA(a); + db = TO_DATA(b); - __post_gc(); - - return d->contents; + strncpy (d->contents , da->contents, LEN(da->data_header)); + strncpy (d->contents + LEN(da->data_header), db->contents, LEN(db->data_header)); + + d->contents[LEN(da->data_header) + LEN(db->data_header)] = 0; + + __post_gc(); + + return d->contents; } extern void* Lsprintf (char * fmt, ...) { - va_list args; - void *s; + va_list args; + void *s; - ASSERT_STRING("sprintf:1", fmt); - - va_start (args, fmt); - fix_unboxed (fmt, args); - - createStringBuf (); + ASSERT_STRING("sprintf:1", fmt); - vprintStringBuf (fmt, args); + va_start (args, fmt); + fix_unboxed (fmt, args); - __pre_gc (); + createStringBuf (); - push_extra_root ((void**)&fmt); - s = Bstring (stringBuf.contents); - pop_extra_root ((void**)&fmt); + vprintStringBuf (fmt, args); - __post_gc (); - - deleteStringBuf (); + __pre_gc (); - return s; + 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); // TODO add (void*) cast? + char *e = getenv (var); + void *s; - __pre_gc (); + if (e == NULL) + return (void*) BOX(0); // TODO add (void*) cast? - s = Bstring (e); + __pre_gc (); - __post_gc (); + s = Bstring (e); - return s; + __post_gc (); + + return s; } extern int Lsystem (char *cmd) { - return BOX (system (cmd)); + return BOX (system (cmd)); } extern void Lfprintf (FILE *f, char *s, ...) { - va_list args = (va_list) BOX (NULL); + 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)); - } + 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); + va_list args = (va_list) BOX (NULL); - ASSERT_STRING("printf:1", s); + ASSERT_STRING("printf:1", s); - va_start (args, s); - fix_unboxed (s, args); - - if (vprintf (s, args) < 0) { - failure ("fprintf (...): %s\n", strerror (errno)); - } + va_start (args, s); + fix_unboxed (s, args); - fflush (stdout); + if (vprintf (s, args) < 0) { + failure ("fprintf (...): %s\n", strerror (errno)); + } + + fflush (stdout); } extern FILE* Lfopen (char *f, char *m) { - FILE* h; + FILE* h; - ASSERT_STRING("fopen:1", f); - ASSERT_STRING("fopen:2", m); + ASSERT_STRING("fopen:1", f); + ASSERT_STRING("fopen:2", m); - h = fopen (f, m); - - if (h) - return h; + h = fopen (f, m); - failure ("fopen (\"%s\", \"%s\"): %s, %s, %s\n", f, m, strerror (errno)); + 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); + ASSERT_BOXED("fclose", f); - fclose (f); + fclose (f); } extern void* LreadLine () { - char *buf; + char *buf; - if (scanf ("%m[^\n]", &buf) == 1) { - void * s = Bstring (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)); + getchar (); - return (void*) BOX (0); + free (buf); + return s; + } + + if (errno != 0) + failure ("readLine (): %s\n", strerror (errno)); + + return (void*) BOX (0); } extern void* Lfread (char *fname) { - FILE *f; + FILE *f; - ASSERT_STRING("fread", fname); + 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); + f = fopen (fname, "r"); - if (fread (s, 1, size, f) == size) { - fclose (f); - return s; - } + 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)); + failure ("fread (\"%s\"): %s\n", fname, strerror (errno)); } extern void Lfwrite (char *fname, char *contents) { - FILE *f; + FILE *f; - ASSERT_STRING("fwrite:1", fname); - ASSERT_STRING("fwrite:2", contents); - - f = fopen (fname, "w"); + ASSERT_STRING("fwrite:1", fname); + ASSERT_STRING("fwrite:2", contents); - if (f) { - if (fprintf (f, "%s", contents) < 0); - else { - fclose (f); - return; + f = fopen (fname, "w"); + + if (f) { + if (fprintf (f, "%s", contents) < 0); + else { + fclose (f); + return; + } } - } - failure ("fwrite (\"%s\"): %s\n", fname, strerror (errno)); + failure ("fwrite (\"%s\"): %s\n", fname, strerror (errno)); } extern void* Lfexists (char *fname) { - FILE *f; + FILE *f; - ASSERT_STRING("fexists", fname); + ASSERT_STRING("fexists", fname); - f = fopen (fname, "r"); - - if (f) return BOX(1); // (void*) cast? + f = fopen (fname, "r"); - return BOX(0); // (void*) cast? + if (f) return (void*) BOX(1); // (void*) cast? + + return (void*) BOX(0); // (void*) cast? } extern void* Lfst (void *v) { - return Belem (v, BOX(0)); + return Belem (v, BOX(0)); } extern void* Lsnd (void *v) { - return Belem (v, BOX(1)); + return Belem (v, BOX(1)); } extern void* Lhd (void *v) { - return Belem (v, BOX(0)); + return Belem (v, BOX(0)); } extern void* Ltl (void *v) { - return Belem (v, BOX(1)); + return Belem (v, BOX(1)); } /* Lread is an implementation of the "read" construct */ extern int Lread () { - int result = BOX(0); + int result = BOX(0); - printf ("> "); - fflush (stdout); - scanf ("%d", &result); + printf ("> "); + fflush (stdout); + scanf ("%d", &result); - return BOX(result); + return BOX(result); } /* Lwrite is an implementation of the "write" construct */ extern int Lwrite (int n) { - printf ("%d\n", UNBOX(n)); - fflush (stdout); + printf ("%d\n", UNBOX(n)); + fflush (stdout); - return 0; + return 0; } extern int Lrandom (int n) { - ASSERT_UNBOXED("Lrandom, 0", n); + ASSERT_UNBOXED("Lrandom, 0", n); - if (UNBOX(n) <= 0) { - failure ("invalid range in random: %d\n", UNBOX(n)); - } - - return BOX (random () % UNBOX(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); + 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 (); + data *a; + int n = argc, *p = NULL; + int i; + + __pre_gc (); #ifdef DEBUG_PRINT - indent++; print_indent (); + 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]); + ((int*)p) [i] = (int) Bstring (argv[i]); #ifdef DEBUG_PRINT - print_indent (); + print_indent (); printf ("set_args: iteration %i <- %p %p\n", i, &p, p); fflush(stdout); #endif - } + } - pop_extra_root ((void**)&p); - __post_gc (); + pop_extra_root ((void**)&p); + __post_gc (); - global_sysargs = p; - push_extra_root ((void**)&global_sysargs); + global_sysargs = p; + push_extra_root ((void**)&global_sysargs); #ifdef DEBUG_PRINT - print_indent (); + print_indent (); printf ("set_args: end\n", n, &p, p); fflush(stdout); indent--; #endif @@ -1451,526 +1443,9 @@ extern void set_args (int argc, char *argv[]) { static int enable_GC = 1; extern void LenableGC () { - enable_GC = 1; + enable_GC = 1; } extern void LdisableGC () { - enable_GC = 0; + 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 (memory_chunk * 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->data_header)) { -#ifdef DEBUG_PRINT - print_indent (); - printf ("gc_copy: IS_FORWARD_PTR: return! %p -> %p\n", obj, (size_t *) d->data_header); - fflush(stdout); - indent--; -#endif - return (size_t *) d->data_header; - } - - copy = current; -#ifdef DEBUG_PRINT - objj = d; -#endif - switch (TAG(d->data_header)) { - case CLOSURE_TAG: -#ifdef DEBUG_PRINT - print_indent (); - printf ("gc_copy:closure_tag; len = %zu\n", LEN(d->data_header)); fflush (stdout); -#endif - i = LEN(d->data_header); - // current += LEN(d->data_header) + 1; - // current += ((LEN(d->data_header) + 1) * sizeof(int) -1) / sizeof(size_t) + 1; - current += i+1; - *copy = d->data_header; - copy++; - d->data_header = (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->data_header)); fflush (stdout); -#endif - current += ((LEN(d->data_header) + 1) * sizeof (int) - 1) / sizeof (size_t) + 1; - *copy = d->data_header; - copy++; - i = LEN(d->data_header); - d->data_header = (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->data_header) + 1); fflush (stdout); -#endif - current += (LEN(d->data_header) + sizeof(int)) / sizeof(size_t) + 1; - *copy = d->data_header; - copy++; - d->data_header = (int) copy; - strcpy ((char*)©[0], (char*) obj); - break; - - case SEXP_TAG : - s = TO_SEXP(obj); -#ifdef DEBUG_PRINT - objj = s; - len1 = LEN(s->contents.data_header); - len2 = LEN(s->data_header); - len3 = LEN(d->data_header); - print_indent (); - printf ("gc_copy:sexp_tag; len1 = %li, len2=%li, len3 = %li\n", - len1, len2, len3); - fflush (stdout); -#endif - i = LEN(s->contents.data_header); - current += i + 2; - *copy = s->tag; - copy++; - *copy = d->data_header; - copy++; - d->data_header = (int) copy; - copy_elements (copy, obj, i); - break; - - default: -#ifdef DEBUG_PRINT - print_indent (); - printf ("ERROR: gc_copy: weird data_header: %p", TAG(d->data_header)); fflush (stdout); - indent--; -#endif - perror ("ERROR: gc_copy: weird data_header"); - 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 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->data_header)) { - - case STRING_TAG: - printf ("(=>%p): STRING\n\t%s; len = %i %zu\n", - d->contents, d->contents, - LEN(d->data_header), LEN(d->data_header) + 1 + sizeof(int)); - fflush (stdout); - len = (LEN(d->data_header) + sizeof(int)) / sizeof(size_t) + 1; - break; - - case CLOSURE_TAG: - printf ("(=>%p): CLOSURE\n\t", d->contents); - len = LEN(d->data_header); - 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->data_header); - 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 * data_header = de_hash (GET_SEXP_TAG(s->data_header)); - printf ("(=>%p): SEXP\n\tdata_header(%s) ", s->contents.contents, data_header); - len = LEN(d->data_header); - 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 data_header %d", TAG(d->data_header)); - perror ("\nprintFromSpace: ERROR: bad data_header"); - 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/runtime/test_main.c b/runtime/test_main.c new file mode 100644 index 000000000..f132f6b36 --- /dev/null +++ b/runtime/test_main.c @@ -0,0 +1,259 @@ +#include +#include +#include +#include +#include "gc.h" +#include "runtime_common.h" + +// function from runtime that maps string to int value +extern int LtagHash (char *s); + +extern void* Bsexp (int n, ...); +extern void* Barray (int bn, ...); +extern void* Bstring (void*); +extern void* Bclosure (int bn, void *entry, ...); + +extern size_t __gc_stack_top, __gc_stack_bottom; + +void test_correct_structure_sizes(void) { + // something like induction base + assert((array_size(0) == get_header_size(ARRAY))); + assert((string_size(0) == get_header_size(STRING) + 1)); // +1 is because of '\0' + assert((sexp_size(0) == get_header_size(SEXP))); + assert((closure_size(0) == get_header_size(CLOSURE))); + + // just check correctness for some small sizes + for (int k = 1; k < 20; ++k) { + assert((array_size(k) == get_header_size(ARRAY) + sizeof (int) * k)); + assert((string_size(k) == get_header_size(STRING) + k + 1)); + assert((sexp_size(k) == get_header_size(SEXP) + sizeof (int) * k)); + assert((closure_size(k) == get_header_size(CLOSURE) + sizeof (int) * k)); + } +} + +void no_gc_tests(void) { + test_correct_structure_sizes(); +} + +// unfortunately there is no generic function pointer that can hold pointer to function with arbitrary signature +extern size_t call_runtime_function(void *virt_stack_pointer, void *function_pointer, size_t num_args, ...); + +#include "virt_stack.h" + +virt_stack* init_test() { + __init(); + virt_stack *st = vstack_create(); + vstack_init(st); + __gc_stack_bottom = (size_t) vstack_top(st); + return st; +} + +void cleanup_test(virt_stack *st) { + vstack_destruct(st); + __shutdown(); +} +void force_gc_cycle(virt_stack *st) { + __gc_stack_top = (size_t) vstack_top(st); + gc_alloc(0); + __gc_stack_top = 0; +} + +void test_simple_string_alloc(void) { + virt_stack *st = init_test(); + + for (int i = 0; i < 5; ++i) { + vstack_push(st, BOX(i)); + } + + vstack_push(st, call_runtime_function(vstack_top(st), Bstring, 1, "abc")); + + const int N = 10; + int ids[N]; + size_t alive = objects_snapshot(ids, N); + assert((alive == 1)); + + cleanup_test(st); +} + +void test_simple_array_alloc(void) { + virt_stack* st = init_test(); + + // allocate array [ BOX(1) ] and push it onto the stack + vstack_push(st, call_runtime_function(vstack_top(st), Barray, 2, BOX(1), BOX(1))); + + const int N = 10; + int ids[N]; + size_t alive = objects_snapshot(ids, N); + assert((alive == 1)); + + cleanup_test(st); +} + +void test_simple_sexp_alloc(void) { + virt_stack* st = init_test(); + + // allocate sexp with one boxed field and push it onto the stack + // calling runtime function Bsexp(BOX(2), BOX(1), LtagHash("test")) + vstack_push(st, call_runtime_function(vstack_top(st), Bsexp, 3, BOX(2), BOX(1), LtagHash("test"))); + + const int N = 10; + int ids[N]; + size_t alive = objects_snapshot(ids, N); + assert((alive == 1)); + + cleanup_test(st); +} + +void test_simple_closure_alloc(void) { + virt_stack* st = init_test(); + + // allocate closure with boxed captured value and push it onto the stack + vstack_push(st, call_runtime_function(vstack_top(st), Bclosure, 3, BOX(1), NULL, BOX(1))); + + const int N = 10; + int ids[N]; + size_t alive = objects_snapshot(ids, N); + assert((alive == 1)); + + cleanup_test(st); +} + +void test_single_object_allocation_with_collection_virtual_stack(void) { + virt_stack *st = init_test(); + + vstack_push(st, call_runtime_function(vstack_top(st), Bstring, 1, "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")); + + const int N = 10; + int ids[N]; + size_t alive = objects_snapshot(ids, N); + assert((alive == 1)); + + cleanup_test(st); +} + +void test_garbage_is_reclaimed(void) { + virt_stack *st = init_test(); + + call_runtime_function(vstack_top(st), Bstring, 1, "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"); + + force_gc_cycle(st); + + const int N = 10; + int ids[N]; + size_t alive = objects_snapshot(ids, N); + assert((alive == 0)); + + cleanup_test(st); +} + +void test_alive_are_not_reclaimed(void) { + virt_stack *st = init_test(); + + vstack_push(st, call_runtime_function(vstack_top(st), Bstring, 1, "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")); + + force_gc_cycle(st); + + const int N = 10; + int ids[N]; + size_t alive = objects_snapshot(ids, N); + assert((alive == 1)); + + cleanup_test(st); +} + +void test_small_tree_compaction(void) { + virt_stack *st = init_test(); + // this one will increase heap size + call_runtime_function(vstack_top(st), Bstring, 1, "aaaaaaaaaaaaaaaaaaaaaa"); + + size_t l = call_runtime_function(vstack_top(st), Bstring, 1, "left-s"); + size_t r = call_runtime_function(vstack_top(st), Bstring, 1, "right-s"); + vstack_push(st, call_runtime_function(vstack_top(st), Bsexp, 4, BOX(3), (size_t)l, (size_t) r, LtagHash("tree"))); + force_gc_cycle(st); + const int SZ = 10; + int ids[SZ]; + size_t alive = objects_snapshot(ids, SZ); + assert((alive == 3)); + + // check that order is indeed preserved + for (int i = 0; i < alive - 1; ++i) { + assert((ids[i] < ids[i + 1])); + } + cleanup_test(st); +} + +extern size_t cur_id; + +size_t generate_random_obj_forest(virt_stack *st, int cnt, int seed) { + srand(seed); + int cur_sz = 0; + size_t alive = 0; + while (cnt) { + --cnt; + if (cur_sz == 0) { + vstack_push(st, BOX(1)); + ++cur_sz; + continue; + } + + size_t pos[2] = {rand() % vstack_size(st), rand() % vstack_size(st)}; + size_t field[2]; + for (int t = 0; t < 2; ++t) { + field[t] = vstack_kth_from_start(st, pos[t]); + } + size_t obj; + + if (rand() % 2) { + obj = call_runtime_function(vstack_top(st), Bsexp, 4, BOX(3), field[0], field[1], LtagHash("test")); + } else { + obj = BOX(1); + } + // whether object is stored on stack + if (rand() % 2 != 0) { + vstack_push(st, obj); + if ((obj & 1) == 0) { + ++alive; + } + } + ++cur_sz; + } + force_gc_cycle(st); + return alive; +} + +void run_stress_test_random_obj_forest(int seed) { + virt_stack *st = init_test(); + + const int SZ = 10000; + + size_t expectedAlive = generate_random_obj_forest(st, SZ, seed); + + int ids[SZ]; + size_t alive = objects_snapshot(ids, SZ); + assert(alive == expectedAlive); + + // check that order is indeed preserved + for (int i = 0; i < alive - 1; ++i) { + assert((ids[i] < ids[i + 1])); + } + + cleanup_test(st); +} + +int main(int argc, char ** argv) { + no_gc_tests(); + + test_simple_string_alloc(); + test_simple_array_alloc(); + test_simple_sexp_alloc(); + test_simple_closure_alloc(); + test_single_object_allocation_with_collection_virtual_stack(); + test_garbage_is_reclaimed(); + test_alive_are_not_reclaimed(); + test_small_tree_compaction(); + + // stress test + for (int s = 0; s < 100; ++s) { + run_stress_test_random_obj_forest(s); + } +} \ No newline at end of file diff --git a/runtime/test_util.s b/runtime/test_util.s new file mode 100644 index 000000000..49f9e9add --- /dev/null +++ b/runtime/test_util.s @@ -0,0 +1,40 @@ +# this is equivalent C-signature for this function +# size_t call_runtime_function(void *stack, void *func_ptr, int num_args, ...) + + .globl call_runtime_function + .type call_runtime_function, @function +call_runtime_function: + pushl %ebp + movl %esp, %ebp + + # store old stack pointer + movl %esp, %edi + + # move esp to point to the virtual stack + movl 8(%ebp), %esp + + # push arguments onto the stack + movl 16(%ebp), %ecx # num_args + test %ecx, %ecx + jz f_call # in case function doesn't have any parameters + + leal 16(%ebp), %eax # pointer to value BEFORE first argument + leal (%eax,%ecx,4), %edx # pointer to last argument (right-to-left) + +push_args_loop: + pushl (%edx) + subl $4, %edx + subl $1, %ecx + jnz push_args_loop + + # call the function +f_call: + movl 12(%ebp), %eax + call *%eax + + # restore the old stack pointer + movl %edi, %esp + + # pop the old frame pointer and return + popl %ebp # epilogue + ret diff --git a/runtime/virt_stack.c b/runtime/virt_stack.c new file mode 100644 index 000000000..532b4a7fd --- /dev/null +++ b/runtime/virt_stack.c @@ -0,0 +1,45 @@ +#include "virt_stack.h" +#include + +virt_stack *vstack_create() { + return malloc(sizeof (virt_stack)); +} + +void vstack_destruct(virt_stack *st) { + free(st); +} + +void vstack_init(virt_stack *st) { + st->cur = RUNTIME_VSTACK_SIZE; + st->buf[st->cur] = 0; +} + +void vstack_push(virt_stack *st, size_t value) { + if (st->cur == 0) { + assert(0); + } + --st->cur; + st->buf[st->cur] = value; +} + +size_t vstack_pop(virt_stack *st) { + if (st->cur == RUNTIME_VSTACK_SIZE) { + assert(0); + } + size_t value = st->buf[st->cur]; + ++st->cur; + return value; +} + +void* vstack_top(virt_stack *st) { + return st->buf + st->cur; +} + +size_t vstack_size(virt_stack *st) { + return RUNTIME_VSTACK_SIZE - st->cur; +} + +size_t vstack_kth_from_start(virt_stack *st, size_t k) { + assert(vstack_size(st) > k); + return st->buf[RUNTIME_VSTACK_SIZE - 1 - k]; +} diff --git a/runtime/virt_stack.h b/runtime/virt_stack.h new file mode 100644 index 000000000..57291c4e4 --- /dev/null +++ b/runtime/virt_stack.h @@ -0,0 +1,33 @@ +// +// Created by egor on 24.04.23. +// + +#ifndef LAMA_RUNTIME_VIRT_STACK_H +#define LAMA_RUNTIME_VIRT_STACK_H +#define RUNTIME_VSTACK_SIZE 100000 + +#include +#include + +struct { + size_t buf[RUNTIME_VSTACK_SIZE + 1]; + size_t cur; +} typedef virt_stack; + +virt_stack *vstack_create(); + +void vstack_destruct(virt_stack *st); + +void vstack_init(virt_stack *st); + +void vstack_push(virt_stack *st, size_t value); + +size_t vstack_pop(virt_stack *st); + +void* vstack_top(virt_stack *st); + +size_t vstack_size(virt_stack *st); + +size_t vstack_kth_from_start(virt_stack *st, size_t k); + +#endif //LAMA_RUNTIME_VIRT_STACK_H