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

First version of mark-compact GC, runtime.c is severely outdated at the moment

Browse source
This commit is contained in:
Egor Sheremetov 2023-03-27 10:09:54 +02:00
parent 413ab65b1f
commit 113c57e7c8
6 changed files with 752 additions and 243 deletions
Download patch file Download diff file Expand all files Collapse all files

7
runtime/Makefile
View file

@ -1,6 +1,9 @@
all: gc_runtime.o runtime.o all: gc_runtime.o gc.o runtime.o
ar rc runtime.a gc_runtime.o runtime.o ar rc runtime.a gc_runtime.o runtime.o gc.o
gc.o: gc.c gc.h
$(CC) -g -fstack-protector-all -m32 -c gc.c
gc_runtime.o: gc_runtime.s gc_runtime.o: gc_runtime.s
$(CC) -g -fstack-protector-all -m32 -c gc_runtime.s $(CC) -g -fstack-protector-all -m32 -c gc_runtime.s

400
runtime/gc.c Normal file
View file

@ -0,0 +1,400 @@
# define _GNU_SOURCE 1
#include <stdio.h>
#include <stdlib.h>
#include <time.h>
#include <sys/mman.h>
#include <string.h>
#include "gc.h"
#include "runtime_common.h"
#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;
#endif
static extra_roots_pool extra_roots;
extern size_t __gc_stack_top, __gc_stack_bottom;
static memory_chunk heap;
void* alloc(size_t size) {
size = BYTES_TO_WORDS(size);
void *p = gc_alloc_on_existing_heap(size);
if (!p) {
// not enough place in heap, need to perform GC cycle
return gc_alloc(size);
}
return p;
}
void* gc_alloc_on_existing_heap(size_t size) {
if (heap.current + size < heap.end) {
void *p = (void *) heap.current;
heap.current += size;
return p;
}
return NULL;
}
void* gc_alloc(size_t size) {
// mark phase
// TODO: add extra roots and static area scan
__gc_root_scan_stack();
// compact phase
compact(size);
}
void compact(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);
memory_chunk new_memory;
new_memory.begin = mremap(heap.begin, WORDS_TO_BYTES(heap.size), WORDS_TO_BYTES(next_heap_size), 0);
if (new_memory.begin == MAP_FAILED) {
perror ("ERROR: compact: 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 + additional_size;
update_references(&new_memory);
physically_relocate(&new_memory);
}
size_t compute_locations() {
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)) {
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));
if (is_marked(obj_content)) {
// forward address is responsible for object header pointer
set_forward_address(obj_content, (size_t) free_ptr);
free_ptr += sz;
}
}
// it will return number of words
return scan_iter.current - 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 *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;
}
heap_next_obj_iterator(&it);
}
}
void physically_relocate(memory_chunk *next_memory) {
heap_iterator from_iter = heap_begin_iterator();
while (!heap_is_done_iterator(&from_iter)) {
void *obj = get_object_content_ptr(from_iter.current);
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));
}
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;
}
void mark(void *obj) {
if (!is_valid_heap_pointer(obj)) {
return;
}
if (is_marked(obj)) {
return;
}
mark_object(obj);
void *header_ptr = get_obj_header_ptr(obj, get_type_row_ptr(obj));
for (
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);
}
}
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));
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);
}
heap.end = heap.begin + INIT_HEAP_SIZE;
heap.size = INIT_HEAP_SIZE;
heap.current = heap.begin;
clear_extra_roots();
}
void clear_extra_roots (void) {
extra_roots.current_free = 0;
}
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);
}
extra_roots.roots[extra_roots.current_free] = p;
extra_roots.current_free++;
}
void pop_extra_root (void ** p) {
if (extra_roots.current_free == 0) {
perror ("ERROR: pop_extra_root: extra_roots are empty");
exit (1);
}
extra_roots.current_free--;
if (extra_roots.roots[extra_roots.current_free] != p) {
perror ("ERROR: pop_extra_root: stack invariant violation");
exit (1);
}
}
/* Functions for tests */
#ifdef DEBUG_VERSION
void objects_snapshot(void *objects_ptr, size_t objects_cnt) {
size_t *ids_ptr = (size_t *) objects_ptr;
size_t i = 0;
for (
heap_iterator it = heap_begin_iterator();
!heap_is_done_iterator(&it) && i < objects_cnt;
heap_next_obj_iterator(&it)
) {
void *header_ptr = it.current;
data *d = TO_DATA(get_object_content_ptr(header_ptr));
ids_ptr[i] = d->id;
}
}
void set_stack(size_t stack_top, size_t stack_bottom) {
__gc_stack_top = stack_top;
__gc_stack_bottom = stack_bottom;
}
void set_extra_roots(size_t extra_roots_size, void **extra_roots_ptr) {
memcpy(extra_roots.roots, extra_roots_ptr, MIN(sizeof(extra_roots.roots), extra_roots_size));
clear_extra_roots();
}
#endif
/* Utility functions */
size_t get_forward_address(void *obj) {
data *d = TO_DATA(obj);
return GET_FORWARD_ADDRESS(d->forward_address);
}
size_t set_forward_address(void *obj, size_t addr) {
data *d = TO_DATA(obj);
SET_FORWARD_ADDRESS(d->forward_address, addr);
}
bool is_marked(void *obj) {
data *d = TO_DATA(obj);
int mark_bit = GET_MARK_BIT(d->forward_address);
return mark_bit;
}
void mark_object(void *obj) {
data *d = TO_DATA(obj);
SET_MARK_BIT(d->forward_address);
}
void unmark_object(void *obj) {
data *d = TO_DATA(obj);
RESET_MARK_BIT(d->forward_address);
}
heap_iterator heap_begin_iterator() {
heap_iterator it = { .current=heap.begin };
return it;
}
void heap_next_obj_iterator(heap_iterator *it) {
void *ptr = it->current;
size_t obj_size = obj_size_header_ptr(ptr);
// make sure we take alignment into consideration
obj_size = BYTES_TO_WORDS(obj_size);
it->current += obj_size;
}
bool heap_is_done_iterator(heap_iterator *it) {
return it->current >= heap.current;
}
lama_type get_type_row_ptr(void *ptr) {
data *data_ptr = TO_DATA(ptr);
return get_type_header_ptr(data_ptr);
}
lama_type get_type_header_ptr(void *ptr) {
int *header = (int *) ptr;
switch (TAG(*header)) {
case ARRAY_TAG:
return ARRAY;
case STRING_TAG:
return STRING;
case CLOSURE_TAG:
return CLOSURE;
case SEXP_TAG:
return SEXP;
default:
perror ("ERROR: get_type_header_ptr: unknown object header");
exit (1);
}
}
size_t obj_size_row_ptr(void *ptr) {
data *data_ptr = TO_DATA(ptr);
return obj_size_header_ptr(data_ptr);
}
size_t obj_size_header_ptr(void *ptr) {
int len = LEN(*(int *) ptr);
switch (get_type_header_ptr(ptr)) {
case ARRAY:
return array_size(len);
case STRING:
return string_size(len);
case CLOSURE:
return closure_size(len);
case SEXP:
return sexp_size(len);
default:
perror ("ERROR: obj_size_header_ptr: unknown object header");
exit (1);
}
}
size_t array_size(size_t sz) {
return get_header_size(ARRAY) + MEMBER_SIZE * sz;
}
size_t string_size(size_t len) {
// string should be null terminated
return get_header_size(STRING) + len + 1;
}
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;
}
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 };
// 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);
}
return it;
}
obj_field_iterator ptr_field_begin_iterator(void *obj) {
obj_field_iterator it = field_begin_iterator(obj);
// corner case when obj has no fields
if (field_is_done_iterator(&it)) {
return it;
}
if (is_valid_heap_pointer(it.cur_field)) {
return it;
}
obj_next_ptr_field_iterator(&it);
return it;
}
void obj_next_field_iterator(obj_field_iterator *it) {
it->cur_field += MEMBER_SIZE;
}
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));
}
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) {
return ptr - get_header_size(type);
}
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) {
return header_ptr + obj_size_header_ptr(header_ptr);
}
size_t get_header_size(lama_type type) {
switch (type) {
case STRING:
case CLOSURE:
case ARRAY:
return DATA_HEADER_SZ;
case SEXP:
return SEXP_ONLY_HEADER_SZ + DATA_HEADER_SZ;
default:
perror ("ERROR: get_header_size: unknown object type");
exit (1);
}
}

164
runtime/gc.h Normal file
View file

@ -0,0 +1,164 @@
#ifndef __LAMA_GC__
#define __LAMA_GC__
# 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 EXTRA_ROOM_HEAP_COEFFICIENT 2 // TODO: tune this parameter
# define MINIMUM_HEAP_CAPACITY (1<<8) // TODO: tune this parameter
#include <stddef.h>
#include <stdbool.h>
#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 {
size_t *current;
} heap_iterator;
typedef struct {
// holds type of object, which fields we are iterating over
lama_type type;
// here a pointer to the object header is stored
void *obj_ptr;
void *cur_field;
} obj_field_iterator;
typedef struct {
size_t * begin;
size_t * end;
size_t * current;
size_t size;
} memory_chunk;
/* GC extra roots */
# define MAX_EXTRA_ROOTS_NUMBER 32
typedef struct {
int current_free;
void ** roots[MAX_EXTRA_ROOTS_NUMBER];
} extra_roots_pool;
// the only GC-related function that should be exposed, others are useful for tests and internal implementation
// allocates object of the given size on the heap
void* alloc(size_t);
// takes number of words as a parameter
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
void mark(void *obj);
// takes number of words that are required to be allocated somewhere on the heap
void compact(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 __pre_gc (void);
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 *);
void clear_extra_roots (void);
void push_extra_root (void ** p);
void pop_extra_root (void ** p);
/* Functions for tests */
#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);
// essential function to mock program stack
void set_stack(size_t stack_top, size_t stack_bottom);
// function to mock extra roots (Lama specific)
void set_extra_roots(size_t extra_roots_size, void** extra_roots_ptr);
#endif
/* Utility functions */
// 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);
// takes a pointer to an object content as an argument, returns whether this object was marked as live
bool is_marked(void *obj);
// takes a pointer to an object content as an argument, marks the object as live
void mark_object(void *obj);
// takes a pointer to an object content as an argument, marks the object as dead
void unmark_object(void *obj);
// returns iterator to an object with the lowest address
heap_iterator heap_begin_iterator();
void heap_next_obj_iterator(heap_iterator *it);
bool heap_is_done_iterator(heap_iterator *it);
// returns correct type when pointer to actual data is passed (header is excluded)
lama_type get_type_row_ptr(void *ptr);
// returns correct type when pointer to an object header is passed
lama_type get_type_header_ptr(void *ptr);
// returns correct object size (together with header) of an object, ptr is pointer to an actual data is passed (header is excluded)
size_t obj_size_row_ptr(void *ptr);
// returns correct object size (together with header) of an object, ptr is pointer to an object header
size_t obj_size_header_ptr(void *ptr);
// returns total padding size that we need to store given object type
size_t get_header_size(lama_type type);
// returns number of bytes that are required to allocate array with 'sz' elements (header included)
size_t array_size(size_t sz);
// returns number of bytes that are required to allocate string of length 'l' (header included)
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 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,
// considering that now we store two versions of header in there)
obj_field_iterator field_begin_iterator(void *obj);
// returns an iterator over object fields which are actual pointers, obj is ptr to object header
// (in case of s-exp, it is mandatory that obj ptr is very beginning of the object,
// considering that now we store two versions of header in there)
obj_field_iterator ptr_field_begin_iterator(void *obj);
// moves the iterator to next object field
void obj_next_field_iterator(obj_field_iterator *it);
// moves the iterator to the next object field which is an actual pointer
void obj_next_ptr_field_iterator(obj_field_iterator *it);
// returns if we are done iterating over fields of the object
bool field_is_done_iterator(obj_field_iterator *it);
// ptr is pointer to the actual object content, returns pointer to the very beginning of the object (header)
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);
#endif

12
runtime/gc_runtime.s
View file

@ -50,7 +50,7 @@ __post_gc:
__post_gc2: __post_gc2:
popl %eax popl %eax
ret ret
// Scan stack for roots // Scan stack for roots
// strting from __gc_stack_top // strting from __gc_stack_top
// till __gc_stack_bottom // till __gc_stack_bottom
@ -68,13 +68,13 @@ loop:
// check that it is not a pointer to code section // check that it is not a pointer to code section
// i.e. the following is not true: // i.e. the following is not true:
// __executable_start <= (%eax) <= __etext // __executable_start <= (%eax) <= __etext
check11: check11:
leal __executable_start, %edx leal __executable_start, %edx
cmpl %ebx, %edx cmpl %ebx, %edx
jna check12 jna check12
jmp check21 jmp check21
check12: check12:
leal __etext, %edx leal __etext, %edx
cmpl %ebx, %edx cmpl %ebx, %edx
jnb next jnb next
@ -82,7 +82,7 @@ check12:
// check that it is not a pointer into the program stack // check that it is not a pointer into the program stack
// i.e. the following is not true: // i.e. the following is not true:
// __gc_stack_bottom <= (%eax) <= __gc_stack_top // __gc_stack_bottom <= (%eax) <= __gc_stack_top
check21: check21:
cmpl %ebx, __gc_stack_top cmpl %ebx, __gc_stack_top
jna check22 jna check22
jmp loop2 jmp loop2
@ -99,7 +99,7 @@ loop2:
gc_run_t: gc_run_t:
pushl %eax pushl %eax
pushl %eax pushl %eax
call gc_test_and_copy_root call gc_test_and_mark_root
addl $4, %esp addl $4, %esp
popl %eax popl %eax
@ -111,6 +111,6 @@ returnn:
movl $0, %eax movl $0, %eax
popl %edx popl %edx
popl %ebx popl %ebx
movl %ebp, %esp movl %ebp, %esp
popl %ebp popl %ebp
ret ret

345
runtime/runtime.c
View file

@ -3,34 +3,19 @@
# define _GNU_SOURCE 1 # define _GNU_SOURCE 1
# include "runtime.h" # include "runtime.h"
# include "runtime_common.h"
# include "gc.h"
# define __ENABLE_GC__ # define __ENABLE_GC__
# ifndef __ENABLE_GC__ # ifndef __ENABLE_GC__
# define alloc malloc # define alloc malloc
# endif # endif
//# define DEBUG_PRINT 1 //# define DEBUG_PRINT 1
#ifdef DEBUG_PRINT /* GC memory_chunk structure and data; declared here in order to allow debug print */
int indent = 0; static memory_chunk from_space;
void print_indent (void) { static memory_chunk to_space;
for (int i = 0; i < indent; i++) printf (" ");
printf("| ");
}
#endif
extern size_t __gc_stack_top, __gc_stack_bottom;
/* GC pool structure and data; declared here in order to allow debug print */
typedef struct {
size_t * begin;
size_t * end;
size_t * current;
size_t size;
} pool;
static pool from_space;
static pool to_space;
size_t *current; size_t *current;
/* end */ /* end */
@ -51,81 +36,6 @@ void __post_gc_subst () {}
# endif # endif
/* end */ /* end */
# define STRING_TAG 0x00000001
# define ARRAY_TAG 0x00000003
# define SEXP_TAG 0x00000005
# define CLOSURE_TAG 0x00000007
# define UNBOXED_TAG 0x00000009 // Not actually a tag; used to return from LkindOf
# define LEN(x) ((x & 0xFFFFFFF8) >> 3)
# define TAG(x) (x & 0x00000007)
# define TO_DATA(x) ((data*)((char*)(x)-sizeof(int)))
# define TO_SEXP(x) ((sexp*)((char*)(x)-2*sizeof(int)))
# ifdef DEBUG_PRINT // GET_SEXP_TAG is necessary for printing from space
# define GET_SEXP_TAG(x) (LEN(x))
#endif
# define UNBOXED(x) (((int) (x)) & 0x0001)
# define UNBOX(x) (((int) (x)) >> 1)
# define BOX(x) ((((int) (x)) << 1) | 0x0001)
/* GC extra roots */
# define MAX_EXTRA_ROOTS_NUMBER 32
typedef struct {
int current_free;
void ** roots[MAX_EXTRA_ROOTS_NUMBER];
} extra_roots_pool;
static extra_roots_pool extra_roots;
void clear_extra_roots (void) {
extra_roots.current_free = 0;
}
void push_extra_root (void ** p) {
# ifdef DEBUG_PRINT
indent++; print_indent ();
printf ("push_extra_root %p %p\n", p, &p); fflush (stdout);
# endif
if (extra_roots.current_free >= MAX_EXTRA_ROOTS_NUMBER) {
perror ("ERROR: push_extra_roots: extra_roots_pool overflow");
exit (1);
}
extra_roots.roots[extra_roots.current_free] = p;
extra_roots.current_free++;
# ifdef DEBUG_PRINT
indent--;
# endif
}
void pop_extra_root (void ** p) {
# ifdef DEBUG_PRINT
indent++; print_indent ();
printf ("pop_extra_root %p %p\n", p, &p); fflush (stdout);
# endif
if (extra_roots.current_free == 0) {
perror ("ERROR: pop_extra_root: extra_roots are empty");
exit (1);
}
extra_roots.current_free--;
if (extra_roots.roots[extra_roots.current_free] != p) {
# ifdef DEBUG_PRINT
print_indent ();
printf ("%i %p %p", extra_roots.current_free,
extra_roots.roots[extra_roots.current_free], p);
fflush (stdout);
# endif
perror ("ERROR: pop_extra_root: stack invariant violation");
exit (1);
}
# ifdef DEBUG_PRINT
indent--;
# endif
}
/* end */
static void vfailure (char *s, va_list args) { static void vfailure (char *s, va_list args) {
fprintf (stderr, "*** FAILURE: "); fprintf (stderr, "*** FAILURE: ");
vfprintf (stderr, s, args); // vprintf (char *, va_list) <-> printf (char *, ...) vfprintf (stderr, s, args); // vprintf (char *, va_list) <-> printf (char *, ...)
@ -153,30 +63,20 @@ void Lassert (void *f, char *s, ...) {
# define ASSERT_UNBOXED(memo, x) \ # define ASSERT_UNBOXED(memo, x) \
do if (!UNBOXED(x)) failure ("unboxed value expected in %s\n", memo); while (0) do if (!UNBOXED(x)) failure ("unboxed value expected in %s\n", memo); while (0)
# define ASSERT_STRING(memo, x) \ # define ASSERT_STRING(memo, x) \
do if (!UNBOXED(x) && TAG(TO_DATA(x)->tag) \ do if (!UNBOXED(x) && TAG(TO_DATA(x)->data_header) \
!= STRING_TAG) failure ("string value expected in %s\n", memo); while (0) != STRING_TAG) failure ("string value expected in %s\n", memo); while (0)
typedef struct {
int tag;
char contents[0];
} data;
typedef struct {
int tag;
data contents;
} sexp;
extern void* alloc (size_t); extern void* alloc (size_t);
extern void* Bsexp (int n, ...); extern void* Bsexp (int n, ...);
extern int LtagHash (char*); extern int LtagHash (char*);
void *global_sysargs; void *global_sysargs;
// Gets a raw tag // Gets a raw data_header
extern int LkindOf (void *p) { extern int LkindOf (void *p) {
if (UNBOXED(p)) return UNBOXED_TAG; if (UNBOXED(p)) return UNBOXED_TAG;
return TAG(TO_DATA(p)->tag); return TAG(TO_DATA(p)->data_header);
} }
// Compare sexprs tags // Compare sexprs tags
@ -189,15 +89,15 @@ extern int LcompareTags (void *p, void *q) {
pd = TO_DATA(p); pd = TO_DATA(p);
qd = TO_DATA(q); qd = TO_DATA(q);
if (TAG(pd->tag) == SEXP_TAG && TAG(qd->tag) == SEXP_TAG) { if (TAG(pd->data_header) == SEXP_TAG && TAG(qd->data_header) == SEXP_TAG) {
return return
#ifndef DEBUG_PRINT #ifndef DEBUG_PRINT
BOX((TO_SEXP(p)->tag) - (TO_SEXP(q)->tag)); BOX((TO_SEXP(p)->tag) - (TO_SEXP(q)->tag));
#else #else
BOX((GET_SEXP_TAG(TO_SEXP(p)->tag)) - (GET_SEXP_TAG(TO_SEXP(p)->tag))); BOX((GET_SEXP_TAG(TO_SEXP(p)->data_header)) - (GET_SEXP_TAG(TO_SEXP(p)->data_header)));
#endif #endif
} }
else failure ("not a sexpr in compareTags: %d, %d\n", TAG(pd->tag), TAG(qd->tag)); else failure ("not a sexpr in compareTags: %d, %d\n", TAG(pd->data_header), TAG(qd->data_header));
return 0; // never happens return 0; // never happens
} }
@ -329,7 +229,7 @@ extern int Llength (void *p) {
ASSERT_BOXED(".length", p); ASSERT_BOXED(".length", p);
a = TO_DATA(p); a = TO_DATA(p);
return BOX(LEN(a->tag)); return BOX(LEN(a->data_header));
} }
static char* chars = "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'"; static char* chars = "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'";
@ -369,7 +269,7 @@ char* de_hash (int n) {
#ifdef DEBUG_PRINT #ifdef DEBUG_PRINT
indent++; print_indent (); indent++; print_indent ();
printf ("de_hash: tag: %d\n", n); fflush (stdout); printf ("de_hash: data_header: %d\n", n); fflush (stdout);
#endif #endif
*p-- = 0; *p-- = 0;
@ -449,7 +349,7 @@ static void printStringBuf (char *fmt, ...) {
vprintStringBuf (fmt, args); vprintStringBuf (fmt, args);
} }
int is_valid_heap_pointer (void *p); //int is_valid_heap_pointer (void *p);
static void printValue (void *p) { static void printValue (void *p) {
data *a = (data*) BOX(NULL); data *a = (data*) BOX(NULL);
@ -463,27 +363,27 @@ static void printValue (void *p) {
a = TO_DATA(p); a = TO_DATA(p);
switch (TAG(a->tag)) { switch (TAG(a->data_header)) {
case STRING_TAG: case STRING_TAG:
printStringBuf ("\"%s\"", a->contents); printStringBuf ("\"%s\"", a->contents);
break; break;
case CLOSURE_TAG: case CLOSURE_TAG:
printStringBuf ("<closure "); printStringBuf ("<closure ");
for (i = 0; i < LEN(a->tag); i++) { for (i = 0; i < LEN(a->data_header); i++) {
if (i) printValue ((void*)((int*) a->contents)[i]); if (i) printValue ((void*)((int*) a->contents)[i]);
else printStringBuf ("0x%x", (void*)((int*) a->contents)[i]); else printStringBuf ("0x%x", (void*)((int*) a->contents)[i]);
if (i != LEN(a->tag) - 1) printStringBuf (", "); if (i != LEN(a->data_header) - 1) printStringBuf (", ");
} }
printStringBuf (">"); printStringBuf (">");
break; break;
case ARRAY_TAG: case ARRAY_TAG:
printStringBuf ("["); printStringBuf ("[");
for (i = 0; i < LEN(a->tag); i++) { for (i = 0; i < LEN(a->data_header); i++) {
printValue ((void*)((int*) a->contents)[i]); printValue ((void*)((int*) a->contents)[i]);
if (i != LEN(a->tag) - 1) printStringBuf (", "); if (i != LEN(a->data_header) - 1) printStringBuf (", ");
} }
printStringBuf ("]"); printStringBuf ("]");
break; break;
@ -492,7 +392,7 @@ static void printValue (void *p) {
#ifndef DEBUG_PRINT #ifndef DEBUG_PRINT
char * tag = de_hash (TO_SEXP(p)->tag); char * tag = de_hash (TO_SEXP(p)->tag);
#else #else
char * tag = de_hash (GET_SEXP_TAG(TO_SEXP(p)->tag)); char * data_header = de_hash (GET_SEXP_TAG(TO_SEXP(p)->data_header));
#endif #endif
if (strcmp (tag, "cons") == 0) { if (strcmp (tag, "cons") == 0) {
@ -500,7 +400,7 @@ static void printValue (void *p) {
printStringBuf ("{"); printStringBuf ("{");
while (LEN(a->tag)) { while (LEN(a->data_header)) {
printValue ((void*)((int*) b->contents)[0]); printValue ((void*)((int*) b->contents)[0]);
b = (data*)((int*) b->contents)[1]; b = (data*)((int*) b->contents)[1];
if (! UNBOXED(b)) { if (! UNBOXED(b)) {
@ -514,11 +414,11 @@ static void printValue (void *p) {
} }
else { else {
printStringBuf ("%s", tag); printStringBuf ("%s", tag);
if (LEN(a->tag)) { if (LEN(a->data_header)) {
printStringBuf (" ("); printStringBuf (" (");
for (i = 0; i < LEN(a->tag); i++) { for (i = 0; i < LEN(a->data_header); i++) {
printValue ((void*)((int*) a->contents)[i]); printValue ((void*)((int*) a->contents)[i]);
if (i != LEN(a->tag) - 1) printStringBuf (", "); if (i != LEN(a->data_header) - 1) printStringBuf (", ");
} }
printStringBuf (")"); printStringBuf (")");
} }
@ -527,7 +427,7 @@ static void printValue (void *p) {
break; break;
default: default:
printStringBuf ("*** invalid tag: 0x%x ***", TAG(a->tag)); printStringBuf ("*** invalid data_header: 0x%x ***", TAG(a->data_header));
} }
} }
} }
@ -540,7 +440,7 @@ static void stringcat (void *p) {
else { else {
a = TO_DATA(p); a = TO_DATA(p);
switch (TAG(a->tag)) { switch (TAG(a->data_header)) {
case STRING_TAG: case STRING_TAG:
printStringBuf ("%s", a->contents); printStringBuf ("%s", a->contents);
break; break;
@ -549,12 +449,12 @@ static void stringcat (void *p) {
#ifndef DEBUG_PRINT #ifndef DEBUG_PRINT
char * tag = de_hash (TO_SEXP(p)->tag); char * tag = de_hash (TO_SEXP(p)->tag);
#else #else
char * tag = de_hash (GET_SEXP_TAG(TO_SEXP(p)->tag)); char * data_header = de_hash (GET_SEXP_TAG(TO_SEXP(p)->data_header));
#endif #endif
if (strcmp (tag, "cons") == 0) { if (strcmp (tag, "cons") == 0) {
data *b = a; data *b = a;
while (LEN(a->tag)) { while (LEN(a->data_header)) {
stringcat ((void*)((int*) b->contents)[0]); stringcat ((void*)((int*) b->contents)[0]);
b = (data*)((int*) b->contents)[1]; b = (data*)((int*) b->contents)[1];
if (! UNBOXED(b)) { if (! UNBOXED(b)) {
@ -563,12 +463,12 @@ static void stringcat (void *p) {
else break; else break;
} }
} }
else printStringBuf ("*** non-list tag: %s ***", tag); else printStringBuf ("*** non-list data_header: %s ***", tag);
} }
break; break;
default: default:
printStringBuf ("*** invalid tag: 0x%x ***", TAG(a->tag)); printStringBuf ("*** invalid data_header: 0x%x ***", TAG(a->data_header));
} }
} }
} }
@ -591,9 +491,9 @@ extern int LmatchSubString (char *subj, char *patt, int pos) {
ASSERT_STRING("matchSubString:2", patt); ASSERT_STRING("matchSubString:2", patt);
ASSERT_UNBOXED("matchSubString:3", pos); ASSERT_UNBOXED("matchSubString:3", pos);
n = LEN (p->tag); n = LEN (p->data_header);
if (n + UNBOX(pos) > LEN(s->tag)) if (n + UNBOX(pos) > LEN(s->data_header))
return BOX(0); return BOX(0);
return BOX(strncmp (subj + UNBOX(pos), patt, n) == 0); return BOX(strncmp (subj + UNBOX(pos), patt, n) == 0);
@ -607,7 +507,7 @@ extern void* Lsubstring (void *subj, int p, int l) {
ASSERT_UNBOXED("substring:2", p); ASSERT_UNBOXED("substring:2", p);
ASSERT_UNBOXED("substring:3", l); ASSERT_UNBOXED("substring:3", l);
if (pp + ll <= LEN(d->tag)) { if (pp + ll <= LEN(d->data_header)) {
data *r; data *r;
__pre_gc (); __pre_gc ();
@ -616,7 +516,7 @@ extern void* Lsubstring (void *subj, int p, int l) {
r = (data*) alloc (ll + 1 + sizeof (int)); r = (data*) alloc (ll + 1 + sizeof (int));
pop_extra_root (&subj); pop_extra_root (&subj);
r->tag = STRING_TAG | (ll << 3); r->data_header = STRING_TAG | (ll << 3);
strncpy (r->contents, (char*) subj + pp, ll); strncpy (r->contents, (char*) subj + pp, ll);
@ -626,7 +526,7 @@ extern void* Lsubstring (void *subj, int p, int l) {
} }
failure ("substring: index out of bounds (position=%d, length=%d, \ failure ("substring: index out of bounds (position=%d, length=%d, \
subject length=%d)", pp, ll, LEN(d->tag)); subject length=%d)", pp, ll, LEN(d->data_header));
} }
extern struct re_pattern_buffer *Lregexp (char *regexp) { extern struct re_pattern_buffer *Lregexp (char *regexp) {
@ -652,7 +552,7 @@ extern int LregexpMatch (struct re_pattern_buffer *b, char *s, int pos) {
ASSERT_STRING("regexpMatch:2", s); ASSERT_STRING("regexpMatch:2", s);
ASSERT_UNBOXED("regexpMatch:3", pos); ASSERT_UNBOXED("regexpMatch:3", pos);
res = re_match (b, s, LEN(TO_DATA(s)->tag), UNBOX(pos), 0); res = re_match (b, s, LEN(TO_DATA(s)->data_header), UNBOX(pos), 0);
/* printf ("regexpMatch %x: %s, res=%d\n", b, s+UNBOX(pos), res); */ /* printf ("regexpMatch %x: %s, res=%d\n", b, s+UNBOX(pos), res); */
@ -680,7 +580,7 @@ void *Lclone (void *p) {
if (UNBOXED(p)) return p; if (UNBOXED(p)) return p;
else { else {
data *a = TO_DATA(p); data *a = TO_DATA(p);
int t = TAG(a->tag), l = LEN(a->tag); int t = TAG(a->data_header), l = LEN(a->data_header);
push_extra_root (&p); push_extra_root (&p);
switch (t) { switch (t) {
@ -717,7 +617,7 @@ void *Lclone (void *p) {
break; break;
default: default:
failure ("invalid tag %d in clone *****\n", t); failure ("invalid data_header %d in clone *****\n", t);
} }
pop_extra_root (&p); pop_extra_root (&p);
} }
@ -743,7 +643,7 @@ int inner_hash (int depth, unsigned acc, void *p) {
if (UNBOXED(p)) return HASH_APPEND(acc, UNBOX(p)); if (UNBOXED(p)) return HASH_APPEND(acc, UNBOX(p));
else if (is_valid_heap_pointer (p)) { else if (is_valid_heap_pointer (p)) {
data *a = TO_DATA(p); data *a = TO_DATA(p);
int t = TAG(a->tag), l = LEN(a->tag), i; int t = TAG(a->data_header), l = LEN(a->data_header), i;
acc = HASH_APPEND(acc, t); acc = HASH_APPEND(acc, t);
acc = HASH_APPEND(acc, l); acc = HASH_APPEND(acc, l);
@ -773,7 +673,7 @@ int inner_hash (int depth, unsigned acc, void *p) {
#ifndef DEBUG_PRINT #ifndef DEBUG_PRINT
int ta = TO_SEXP(p)->tag; int ta = TO_SEXP(p)->tag;
#else #else
int ta = GET_SEXP_TAG(TO_SEXP(p)->tag); int ta = GET_SEXP_TAG(TO_SEXP(p)->data_header);
#endif #endif
acc = HASH_APPEND(acc, ta); acc = HASH_APPEND(acc, ta);
i = 0; i = 0;
@ -781,7 +681,7 @@ int inner_hash (int depth, unsigned acc, void *p) {
} }
default: default:
failure ("invalid tag %d in hash *****\n", t); failure ("invalid data_header %d in hash *****\n", t);
} }
for (; i<l; i++) for (; i<l; i++)
@ -830,8 +730,8 @@ extern int Lcompare (void *p, void *q) {
if (is_valid_heap_pointer (p)) { if (is_valid_heap_pointer (p)) {
if (is_valid_heap_pointer (q)) { if (is_valid_heap_pointer (q)) {
data *a = TO_DATA(p), *b = TO_DATA(q); data *a = TO_DATA(p), *b = TO_DATA(q);
int ta = TAG(a->tag), tb = TAG(b->tag); int ta = TAG(a->data_header), tb = TAG(b->data_header);
int la = LEN(a->tag), lb = LEN(b->tag); int la = LEN(a->data_header), lb = LEN(b->data_header);
int i; int i;
COMPARE_AND_RETURN (ta, tb); COMPARE_AND_RETURN (ta, tb);
@ -855,7 +755,7 @@ extern int Lcompare (void *p, void *q) {
#ifndef DEBUG_PRINT #ifndef DEBUG_PRINT
int ta = TO_SEXP(p)->tag, tb = TO_SEXP(q)->tag; int ta = TO_SEXP(p)->tag, tb = TO_SEXP(q)->tag;
#else #else
int ta = GET_SEXP_TAG(TO_SEXP(p)->tag), tb = GET_SEXP_TAG(TO_SEXP(q)->tag); int ta = GET_SEXP_TAG(TO_SEXP(p)->data_header), tb = GET_SEXP_TAG(TO_SEXP(q)->data_header);
#endif #endif
COMPARE_AND_RETURN (ta, tb); COMPARE_AND_RETURN (ta, tb);
COMPARE_AND_RETURN (la, lb); COMPARE_AND_RETURN (la, lb);
@ -864,7 +764,7 @@ extern int Lcompare (void *p, void *q) {
} }
default: default:
failure ("invalid tag %d in compare *****\n", ta); failure ("invalid data_header %d in compare *****\n", ta);
} }
for (; i<la; i++) { for (; i<la; i++) {
@ -890,7 +790,7 @@ extern void* Belem (void *p, int i) {
a = TO_DATA(p); a = TO_DATA(p);
i = UNBOX(i); i = UNBOX(i);
if (TAG(a->tag) == STRING_TAG) { if (TAG(a->data_header) == STRING_TAG) {
return (void*) BOX(a->contents[i]); return (void*) BOX(a->contents[i]);
} }
@ -908,7 +808,7 @@ extern void* LmakeArray (int length) {
n = UNBOX(length); n = UNBOX(length);
r = (data*) alloc (sizeof(int) * (n+1)); r = (data*) alloc (sizeof(int) * (n+1));
r->tag = ARRAY_TAG | (n << 3); r->data_header = ARRAY_TAG | (n << 3);
p = (int*) r->contents; p = (int*) r->contents;
while (n--) *p++ = BOX(0); while (n--) *p++ = BOX(0);
@ -928,7 +828,7 @@ extern void* LmakeString (int length) {
r = (data*) alloc (n + 1 + sizeof (int)); r = (data*) alloc (n + 1 + sizeof (int));
r->tag = STRING_TAG | (n << 3); r->data_header = STRING_TAG | (n << 3);
__post_gc(); __post_gc();
@ -1023,7 +923,7 @@ extern void* Bclosure (int bn, void *entry, ...) {
r = (data*) alloc (sizeof(int) * (n+2)); r = (data*) alloc (sizeof(int) * (n+2));
r->tag = CLOSURE_TAG | ((n + 1) << 3); r->data_header = CLOSURE_TAG | ((n + 1) << 3);
((void**) r->contents)[0] = entry; ((void**) r->contents)[0] = entry;
va_start(args, entry); va_start(args, entry);
@ -1065,7 +965,7 @@ extern void* Barray (int bn, ...) {
#endif #endif
r = (data*) alloc (sizeof(int) * (n+1)); r = (data*) alloc (sizeof(int) * (n+1));
r->tag = ARRAY_TAG | (n << 3); r->data_header = ARRAY_TAG | (n << 3);
va_start(args, bn); va_start(args, bn);
@ -1102,7 +1002,7 @@ extern void* Bsexp (int bn, ...) {
d = &(r->contents); d = &(r->contents);
r->tag = 0; r->tag = 0;
d->tag = SEXP_TAG | ((n-1) << 3); d->data_header = SEXP_TAG | ((n - 1) << 3);
va_start(args, bn); va_start(args, bn);
@ -1116,7 +1016,7 @@ extern void* Bsexp (int bn, ...) {
r->tag = UNBOX(va_arg(args, int)); r->tag = UNBOX(va_arg(args, int));
#ifdef DEBUG_PRINT #ifdef DEBUG_PRINT
r->tag = SEXP_TAG | ((r->tag) << 3); r->data_header = SEXP_TAG | ((r->data_header) << 3);
print_indent (); print_indent ();
printf("Bsexp: ends\n"); fflush (stdout); printf("Bsexp: ends\n"); fflush (stdout);
indent--; indent--;
@ -1136,10 +1036,10 @@ extern int Btag (void *d, int t, int n) {
else { else {
r = TO_DATA(d); r = TO_DATA(d);
#ifndef DEBUG_PRINT #ifndef DEBUG_PRINT
return BOX(TAG(r->tag) == SEXP_TAG && TO_SEXP(d)->tag == UNBOX(t) && LEN(r->tag) == UNBOX(n)); return BOX(TAG(r->data_header) == SEXP_TAG && TO_SEXP(d)->tag == UNBOX(t) && LEN(r->data_header) == UNBOX(n));
#else #else
return BOX(TAG(r->tag) == SEXP_TAG && return BOX(TAG(r->data_header) == SEXP_TAG &&
GET_SEXP_TAG(TO_SEXP(d)->tag) == UNBOX(t) && LEN(r->tag) == UNBOX(n)); GET_SEXP_TAG(TO_SEXP(d)->data_header) == UNBOX(t) && LEN(r->data_header) == UNBOX(n));
#endif #endif
} }
} }
@ -1150,7 +1050,7 @@ extern int Barray_patt (void *d, int n) {
if (UNBOXED(d)) return BOX(0); if (UNBOXED(d)) return BOX(0);
else { else {
r = TO_DATA(d); r = TO_DATA(d);
return BOX(TAG(r->tag) == ARRAY_TAG && LEN(r->tag) == UNBOX(n)); return BOX(TAG(r->data_header) == ARRAY_TAG && LEN(r->data_header) == UNBOX(n));
} }
} }
@ -1164,16 +1064,16 @@ extern int Bstring_patt (void *x, void *y) {
else { else {
rx = TO_DATA(x); ry = TO_DATA(y); rx = TO_DATA(x); ry = TO_DATA(y);
if (TAG(rx->tag) != STRING_TAG) return BOX(0); if (TAG(rx->data_header) != STRING_TAG) return BOX(0);
return BOX(strcmp (rx->contents, ry->contents) == 0 ? 1 : 0); return BOX(strcmp (rx->contents, ry->contents) == 0 ? 1 : 0); // TODO: ???
} }
} }
extern int Bclosure_tag_patt (void *x) { extern int Bclosure_tag_patt (void *x) {
if (UNBOXED(x)) return BOX(0); if (UNBOXED(x)) return BOX(0);
return BOX(TAG(TO_DATA(x)->tag) == CLOSURE_TAG); return BOX(TAG(TO_DATA(x)->data_header) == CLOSURE_TAG);
} }
extern int Bboxed_patt (void *x) { extern int Bboxed_patt (void *x) {
@ -1187,19 +1087,19 @@ extern int Bunboxed_patt (void *x) {
extern int Barray_tag_patt (void *x) { extern int Barray_tag_patt (void *x) {
if (UNBOXED(x)) return BOX(0); if (UNBOXED(x)) return BOX(0);
return BOX(TAG(TO_DATA(x)->tag) == ARRAY_TAG); return BOX(TAG(TO_DATA(x)->data_header) == ARRAY_TAG);
} }
extern int Bstring_tag_patt (void *x) { extern int Bstring_tag_patt (void *x) {
if (UNBOXED(x)) return BOX(0); if (UNBOXED(x)) return BOX(0);
return BOX(TAG(TO_DATA(x)->tag) == STRING_TAG); return BOX(TAG(TO_DATA(x)->data_header) == STRING_TAG);
} }
extern int Bsexp_tag_patt (void *x) { extern int Bsexp_tag_patt (void *x) {
if (UNBOXED(x)) return BOX(0); if (UNBOXED(x)) return BOX(0);
return BOX(TAG(TO_DATA(x)->tag) == SEXP_TAG); return BOX(TAG(TO_DATA(x)->data_header) == SEXP_TAG);
} }
extern void* Bsta (void *v, int i, void *x) { extern void* Bsta (void *v, int i, void *x) {
@ -1207,7 +1107,7 @@ extern void* Bsta (void *v, int i, void *x) {
ASSERT_BOXED(".sta:3", x); ASSERT_BOXED(".sta:3", x);
// ASSERT_UNBOXED(".sta:2", i); // ASSERT_UNBOXED(".sta:2", i);
if (TAG(TO_DATA(x)->tag) == STRING_TAG)((char*) x)[UNBOX(i)] = (char) UNBOX(v); if (TAG(TO_DATA(x)->data_header) == STRING_TAG)((char*) x)[UNBOX(i)] = (char) UNBOX(v);
else ((int*) x)[UNBOX(i)] = (int) v; else ((int*) x)[UNBOX(i)] = (int) v;
return v; return v;
@ -1264,19 +1164,19 @@ extern void* /*Lstrcat*/ Li__Infix_4343 (void *a, void *b) {
push_extra_root (&a); push_extra_root (&a);
push_extra_root (&b); push_extra_root (&b);
d = (data *) alloc (sizeof(int) + LEN(da->tag) + LEN(db->tag) + 1); d = (data *) alloc (sizeof(int) + LEN(da->data_header) + LEN(db->data_header) + 1);
pop_extra_root (&b); pop_extra_root (&b);
pop_extra_root (&a); pop_extra_root (&a);
da = TO_DATA(a); da = TO_DATA(a);
db = TO_DATA(b); db = TO_DATA(b);
d->tag = STRING_TAG | ((LEN(da->tag) + LEN(db->tag)) << 3); d->data_header = STRING_TAG | ((LEN(da->data_header) + LEN(db->data_header)) << 3);
strncpy (d->contents , da->contents, LEN(da->tag)); strncpy (d->contents , da->contents, LEN(da->data_header));
strncpy (d->contents + LEN(da->tag), db->contents, LEN(db->tag)); strncpy (d->contents + LEN(da->data_header), db->contents, LEN(db->data_header));
d->contents[LEN(da->tag) + LEN(db->tag)] = 0; d->contents[LEN(da->data_header) + LEN(db->data_header)] = 0;
__post_gc(); __post_gc();
@ -1314,7 +1214,7 @@ extern void* LgetEnv (char *var) {
void *s; void *s;
if (e == NULL) if (e == NULL)
return BOX(0); return BOX(0); // TODO add (void*) cast?
__pre_gc (); __pre_gc ();
@ -1446,9 +1346,9 @@ extern void* Lfexists (char *fname) {
f = fopen (fname, "r"); f = fopen (fname, "r");
if (f) return BOX(1); if (f) return BOX(1); // (void*) cast?
return BOX(0); return BOX(0); // (void*) cast?
} }
extern void* Lfst (void *v) { extern void* Lfst (void *v) {
@ -1582,7 +1482,7 @@ static size_t SPACE_SIZE = 256 * 1024 * 1024;
// static size_t SPACE_SIZE = 128; // static size_t SPACE_SIZE = 128;
// static size_t SPACE_SIZE = 1024 * 1024; // static size_t SPACE_SIZE = 1024 * 1024;
static int free_pool (pool * p) { static int free_pool (memory_chunk * p) {
size_t *a = p->begin, b = p->size; size_t *a = p->begin, b = p->size;
p->begin = NULL; p->begin = NULL;
p->size = 0; p->size = 0;
@ -1746,58 +1646,58 @@ extern size_t * gc_copy (size_t *obj) {
exit (1); exit (1);
} }
if (IS_FORWARD_PTR(d->tag)) { if (IS_FORWARD_PTR(d->data_header)) {
#ifdef DEBUG_PRINT #ifdef DEBUG_PRINT
print_indent (); print_indent ();
printf ("gc_copy: IS_FORWARD_PTR: return! %p -> %p\n", obj, (size_t *) d->tag); printf ("gc_copy: IS_FORWARD_PTR: return! %p -> %p\n", obj, (size_t *) d->data_header);
fflush(stdout); fflush(stdout);
indent--; indent--;
#endif #endif
return (size_t *) d->tag; return (size_t *) d->data_header;
} }
copy = current; copy = current;
#ifdef DEBUG_PRINT #ifdef DEBUG_PRINT
objj = d; objj = d;
#endif #endif
switch (TAG(d->tag)) { switch (TAG(d->data_header)) {
case CLOSURE_TAG: case CLOSURE_TAG:
#ifdef DEBUG_PRINT #ifdef DEBUG_PRINT
print_indent (); print_indent ();
printf ("gc_copy:closure_tag; len = %zu\n", LEN(d->tag)); fflush (stdout); printf ("gc_copy:closure_tag; len = %zu\n", LEN(d->data_header)); fflush (stdout);
#endif #endif
i = LEN(d->tag); i = LEN(d->data_header);
// current += LEN(d->tag) + 1; // current += LEN(d->data_header) + 1;
// current += ((LEN(d->tag) + 1) * sizeof(int) -1) / sizeof(size_t) + 1; // current += ((LEN(d->data_header) + 1) * sizeof(int) -1) / sizeof(size_t) + 1;
current += i+1; current += i+1;
*copy = d->tag; *copy = d->data_header;
copy++; copy++;
d->tag = (int) copy; d->data_header = (int) copy;
copy_elements (copy, obj, i); copy_elements (copy, obj, i);
break; break;
case ARRAY_TAG: case ARRAY_TAG:
#ifdef DEBUG_PRINT #ifdef DEBUG_PRINT
print_indent (); print_indent ();
printf ("gc_copy:array_tag; len = %zu\n", LEN(d->tag)); fflush (stdout); printf ("gc_copy:array_tag; len = %zu\n", LEN(d->data_header)); fflush (stdout);
#endif #endif
current += ((LEN(d->tag) + 1) * sizeof (int) - 1) / sizeof (size_t) + 1; current += ((LEN(d->data_header) + 1) * sizeof (int) - 1) / sizeof (size_t) + 1;
*copy = d->tag; *copy = d->data_header;
copy++; copy++;
i = LEN(d->tag); i = LEN(d->data_header);
d->tag = (int) copy; d->data_header = (int) copy;
copy_elements (copy, obj, i); copy_elements (copy, obj, i);
break; break;
case STRING_TAG: case STRING_TAG:
#ifdef DEBUG_PRINT #ifdef DEBUG_PRINT
print_indent (); print_indent ();
printf ("gc_copy:string_tag; len = %d\n", LEN(d->tag) + 1); fflush (stdout); printf ("gc_copy:string_tag; len = %d\n", LEN(d->data_header) + 1); fflush (stdout);
#endif #endif
current += (LEN(d->tag) + sizeof(int)) / sizeof(size_t) + 1; current += (LEN(d->data_header) + sizeof(int)) / sizeof(size_t) + 1;
*copy = d->tag; *copy = d->data_header;
copy++; copy++;
d->tag = (int) copy; d->data_header = (int) copy;
strcpy ((char*)&copy[0], (char*) obj); strcpy ((char*)&copy[0], (char*) obj);
break; break;
@ -1805,31 +1705,31 @@ extern size_t * gc_copy (size_t *obj) {
s = TO_SEXP(obj); s = TO_SEXP(obj);
#ifdef DEBUG_PRINT #ifdef DEBUG_PRINT
objj = s; objj = s;
len1 = LEN(s->contents.tag); len1 = LEN(s->contents.data_header);
len2 = LEN(s->tag); len2 = LEN(s->data_header);
len3 = LEN(d->tag); len3 = LEN(d->data_header);
print_indent (); print_indent ();
printf ("gc_copy:sexp_tag; len1 = %li, len2=%li, len3 = %li\n", printf ("gc_copy:sexp_tag; len1 = %li, len2=%li, len3 = %li\n",
len1, len2, len3); len1, len2, len3);
fflush (stdout); fflush (stdout);
#endif #endif
i = LEN(s->contents.tag); i = LEN(s->contents.data_header);
current += i + 2; current += i + 2;
*copy = s->tag; *copy = s->tag;
copy++; copy++;
*copy = d->tag; *copy = d->data_header;
copy++; copy++;
d->tag = (int) copy; d->data_header = (int) copy;
copy_elements (copy, obj, i); copy_elements (copy, obj, i);
break; break;
default: default:
#ifdef DEBUG_PRINT #ifdef DEBUG_PRINT
print_indent (); print_indent ();
printf ("ERROR: gc_copy: weird tag: %p", TAG(d->tag)); fflush (stdout); printf ("ERROR: gc_copy: weird data_header: %p", TAG(d->data_header)); fflush (stdout);
indent--; indent--;
#endif #endif
perror ("ERROR: gc_copy: weird tag"); perror ("ERROR: gc_copy: weird data_header");
exit (1); exit (1);
return (obj); return (obj);
} }
@ -1873,31 +1773,6 @@ extern void gc_root_scan_data (void) {
} }
} }
static inline void init_extra_roots (void) {
extra_roots.current_free = 0;
}
extern void __init (void) {
size_t space_size = SPACE_SIZE * sizeof(size_t);
srandom (time (NULL));
from_space.begin = mmap (NULL, space_size, PROT_READ | PROT_WRITE,
MAP_PRIVATE | MAP_ANONYMOUS | MAP_32BIT, -1, 0);
to_space.begin = NULL;
if (from_space.begin == MAP_FAILED) {
perror ("EROOR: init_pool: mmap failed\n");
exit (1);
}
from_space.current = from_space.begin;
from_space.end = from_space.begin + SPACE_SIZE;
from_space.size = SPACE_SIZE;
to_space.current = NULL;
to_space.end = NULL;
to_space.size = 0;
init_extra_roots ();
}
static void* gc (size_t size) { static void* gc (size_t size) {
if (! enable_GC) { if (! enable_GC) {
Lfailure ("GC disabled"); Lfailure ("GC disabled");
@ -1987,19 +1862,19 @@ static void printFromSpace (void) {
printf ("data at %p", cur); printf ("data at %p", cur);
d = (data *) cur; d = (data *) cur;
switch (TAG(d->tag)) { switch (TAG(d->data_header)) {
case STRING_TAG: case STRING_TAG:
printf ("(=>%p): STRING\n\t%s; len = %i %zu\n", printf ("(=>%p): STRING\n\t%s; len = %i %zu\n",
d->contents, d->contents, d->contents, d->contents,
LEN(d->tag), LEN(d->tag) + 1 + sizeof(int)); LEN(d->data_header), LEN(d->data_header) + 1 + sizeof(int));
fflush (stdout); fflush (stdout);
len = (LEN(d->tag) + sizeof(int)) / sizeof(size_t) + 1; len = (LEN(d->data_header) + sizeof(int)) / sizeof(size_t) + 1;
break; break;
case CLOSURE_TAG: case CLOSURE_TAG:
printf ("(=>%p): CLOSURE\n\t", d->contents); printf ("(=>%p): CLOSURE\n\t", d->contents);
len = LEN(d->tag); len = LEN(d->data_header);
for (int i = 0; i < len; i++) { for (int i = 0; i < len; i++) {
int elem = ((int*)d->contents)[i]; int elem = ((int*)d->contents)[i];
if (UNBOXED(elem)) printf ("%d ", elem); if (UNBOXED(elem)) printf ("%d ", elem);
@ -2012,7 +1887,7 @@ static void printFromSpace (void) {
case ARRAY_TAG: case ARRAY_TAG:
printf ("(=>%p): ARRAY\n\t", d->contents); printf ("(=>%p): ARRAY\n\t", d->contents);
len = LEN(d->tag); len = LEN(d->data_header);
for (int i = 0; i < len; i++) { for (int i = 0; i < len; i++) {
int elem = ((int*)d->contents)[i]; int elem = ((int*)d->contents)[i];
if (UNBOXED(elem)) printf ("%d ", elem); if (UNBOXED(elem)) printf ("%d ", elem);
@ -2026,9 +1901,9 @@ static void printFromSpace (void) {
case SEXP_TAG: case SEXP_TAG:
s = (sexp *) d; s = (sexp *) d;
d = (data *) &(s->contents); d = (data *) &(s->contents);
char * tag = de_hash (GET_SEXP_TAG(s->tag)); char * data_header = de_hash (GET_SEXP_TAG(s->data_header));
printf ("(=>%p): SEXP\n\ttag(%s) ", s->contents.contents, tag); printf ("(=>%p): SEXP\n\tdata_header(%s) ", s->contents.contents, data_header);
len = LEN(d->tag); len = LEN(d->data_header);
tmp = (s->contents.contents); tmp = (s->contents.contents);
for (int i = 0; i < len; i++) { for (int i = 0; i < len; i++) {
int elem = ((int*)tmp)[i]; int elem = ((int*)tmp)[i];
@ -2046,8 +1921,8 @@ static void printFromSpace (void) {
return; return;
default: default:
printf ("\nprintFromSpace: ERROR: bad tag %d", TAG(d->tag)); printf ("\nprintFromSpace: ERROR: bad data_header %d", TAG(d->data_header));
perror ("\nprintFromSpace: ERROR: bad tag"); perror ("\nprintFromSpace: ERROR: bad data_header");
fflush (stdout); fflush (stdout);
exit (1); exit (1);
} }

67
runtime/runtime_common.h Normal file
View file

@ -0,0 +1,67 @@
#ifndef __LAMA_RUNTIME_COMMON__
#define __LAMA_RUNTIME_COMMON__
#define DEBUG_VERSION
# define STRING_TAG 0x00000001
//# define STRING_TAG 0x00000000
# define ARRAY_TAG 0x00000003
//# define ARRAY_TAG 0x00000002
# define SEXP_TAG 0x00000005
//# define SEXP_TAG 0x00000004
# define CLOSURE_TAG 0x00000007
//# define CLOSURE_TAG 0x00000006
# define UNBOXED_TAG 0x00000009 // Not actually a data_header; used to return from LkindOf
# define LEN(x) ((x & 0xFFFFFFF8) >> 3)
# define TAG(x) (x & 0x00000007)
//# define TAG(x) (x & 0x00000006)
# define SEXP_ONLY_HEADER_SZ (2 * sizeof(int))
# ifndef DEBUG_VERSION
# define DATA_HEADER_SZ (sizeof(size_t) + sizeof(int))
# else
# define DATA_HEADER_SZ (sizeof(size_t) + sizeof(size_t) + sizeof(int))
#endif
# define MEMBER_SIZE sizeof(int)
# define TO_DATA(x) ((data*)((char*)(x)-DATA_HEADER_SZ))
# define TO_SEXP(x) ((sexp*)((char*)(x)-DATA_HEADER_SZ-SEXP_ONLY_HEADER_SZ))
# define UNBOXED(x) (((int) (x)) & 0x0001)
# define UNBOX(x) (((int) (x)) >> 1)
# define BOX(x) ((((int) (x)) << 1) | 0x0001)
# define BYTES_TO_WORDS(bytes) (((bytes) - 1) / sizeof(size_t) + 1)
# define WORDS_TO_BYTES(words) ((words) * sizeof(size_t))
// CAREFUL WITH DOUBLE EVALUATION!
#define MAX(x, y) (((x) > (y)) ? (x) : (y))
#define MIN(x, y) (((x) < (y)) ? (x) : (y))
typedef struct {
// store tag in the last three bits to understand what structure this is, other bits are filled with
// other utility info (i.e., size for array, number of fields for s-expression)
int data_header;
#ifdef DEBUG_VERSION
size_t id;
#endif
// last bit is used as MARK-BIT, the rest are used to store address where object should move
// last bit can be used because due to alignment we can assume that last two bits are always 0's
size_t forward_address;
char contents[0];
} data;
typedef struct {
// duplicates contents.data_header in order to be able to understand if it is s-exp during iteration over heap
int sexp_header;
// stores hashed s-expression constructor name
int tag;
data contents;
} sexp;
#endif