Added built-in structure types and interpreter core (w/o bytecode).
Improved timing resolution by using clock_gettime() instead of clock(). Also gave project a name: Rosella. Play on 'Parrot' (Perl 6 VM).
This commit is contained in:
parent
080906fa72
commit
0a2f13b523
15
Makefile
15
Makefile
|
|
@ -1,14 +1,15 @@
|
||||||
CFLAGS = -std=c99
|
CFLAGS = -std=c99
|
||||||
|
LDFLAGS = -lrt
|
||||||
|
|
||||||
ifeq ($(DEBUG),yes)
|
ifeq ($(DEBUG),yes)
|
||||||
CFLAGS += -g
|
CFLAGS += -g
|
||||||
PROFILE = no
|
PROFILE = no
|
||||||
dummy := $(shell rm -f gc_test *.gcda *.gcno *.o)
|
dummy := $(shell rm -f rosella *.gcda *.gcno *.o)
|
||||||
else
|
else
|
||||||
CFLAGS += -O3 -DNDEBUG -march=nocona
|
CFLAGS += -O3 -DNDEBUG -march=nocona
|
||||||
endif
|
endif
|
||||||
|
|
||||||
all: gc_test
|
all: rosella
|
||||||
.PHONY: all clean
|
.PHONY: all clean
|
||||||
|
|
||||||
ifneq ($(PROFILE),no)
|
ifneq ($(PROFILE),no)
|
||||||
|
|
@ -18,13 +19,15 @@ endif
|
||||||
|
|
||||||
ifneq (,$(wildcard *.gcda))
|
ifneq (,$(wildcard *.gcda))
|
||||||
CFLAGS += -fprofile-use
|
CFLAGS += -fprofile-use
|
||||||
dummy := $(shell rm -f gc_test *.o)
|
dummy := $(shell rm -f rosella *.o)
|
||||||
endif
|
endif
|
||||||
|
|
||||||
clean:
|
clean:
|
||||||
-rm -f gc_test *.o *.gcda *.gcno
|
-rm -f rosella *.o *.gcda *.gcno
|
||||||
|
|
||||||
gc_test: gc_test.o gc.o
|
rosella: rosella.o gc.o builtin.o interp.o
|
||||||
|
|
||||||
gc_test.o: gc_test.c gc.h
|
rosella.o: rosella.c gc.h builtin.h interp.h
|
||||||
gc.o: gc.c gc.h
|
gc.o: gc.c gc.h
|
||||||
|
builtin.o: builtin.c builtin.h gc.h
|
||||||
|
interp.o: interp.c interp.h gc.h builtin.h
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,181 @@
|
||||||
|
#include <assert.h>
|
||||||
|
#include <inttypes.h>
|
||||||
|
#include <stdbool.h>
|
||||||
|
#include <stdlib.h>
|
||||||
|
#include <string.h>
|
||||||
|
|
||||||
|
#include "gc.h"
|
||||||
|
#include "builtin.h"
|
||||||
|
|
||||||
|
static gc_root_t builtin_list;
|
||||||
|
|
||||||
|
/* Returns a byte string w/ bytes from 's' (excl. terminating NUL). */
|
||||||
|
static value_t string_to_value(const char *s);
|
||||||
|
|
||||||
|
/* Return value is a new C string which must be free()'d by caller. */
|
||||||
|
static char *value_to_string(value_t v);
|
||||||
|
|
||||||
|
/* Like strcmp(), but for byte strings. */
|
||||||
|
static int byte_strcmp(value_t s1, value_t s2);
|
||||||
|
|
||||||
|
void builtin_init(void)
|
||||||
|
{
|
||||||
|
gc_root_t ms_root, tmp_root;
|
||||||
|
|
||||||
|
register_gc_root(&builtin_list, NIL);
|
||||||
|
|
||||||
|
#define SS(x) STRUCTURE_SLOT_ ## x
|
||||||
|
|
||||||
|
/* (Meta-)Structure: Instances of this structure describe structures. */
|
||||||
|
register_gc_root(&ms_root, make_struct(NIL, STRUCTURE_SLOTS));
|
||||||
|
register_builtin(BI_STRUCTURE, ms_root.value);
|
||||||
|
|
||||||
|
/* Metastruct is both a structure and a structure description,
|
||||||
|
* and thus is an instance of itself. */
|
||||||
|
_get_struct(ms_root.value)->type = ms_root.value;
|
||||||
|
/* Slot 1: Name */
|
||||||
|
_get_struct(ms_root.value)->slots[SS(NAME)] = string_to_value("structure");
|
||||||
|
/* Slot 2: Super/parent structure type, or NIL */
|
||||||
|
_get_struct(ms_root.value)->slots[SS(SUPER)] = NIL;
|
||||||
|
/* Slot 3: Vector of slot names; size == total number of slots (excl. type) */
|
||||||
|
_get_struct(ms_root.value)->slots[SS(SLOTS)] = make_vector(STRUCTURE_SLOTS, NIL);
|
||||||
|
{
|
||||||
|
gc_root_t vec_root;
|
||||||
|
register_gc_root(&vec_root, _get_struct(ms_root.value)->slots[SS(SLOTS)]);
|
||||||
|
_get_vector(vec_root.value)->elements[SS(NAME)] = string_to_value("name");
|
||||||
|
_get_vector(vec_root.value)->elements[SS(SUPER)] = string_to_value("super");
|
||||||
|
_get_vector(vec_root.value)->elements[SS(SLOTS)] = string_to_value("slots");
|
||||||
|
_get_vector(vec_root.value)->elements[SS(CALLABLE)] = string_to_value("callable");
|
||||||
|
unregister_gc_root(&vec_root);
|
||||||
|
}
|
||||||
|
/* Slot 4: Callable object used as proxy when structure is APPLY'd. */
|
||||||
|
/* Can be LAMBDA or callable structure instance. */
|
||||||
|
_get_struct(ms_root.value)->slots[SS(CALLABLE)] = NIL;
|
||||||
|
|
||||||
|
#define TS(x) TEMPLATE_SLOT_ ## x
|
||||||
|
|
||||||
|
/* Template: Instances of this structure describe what a LAMBDA
|
||||||
|
* will look like when instanciated with the 'lambda' bytecode. */
|
||||||
|
register_gc_root(&tmp_root, make_struct(ms_root.value, STRUCTURE_SLOTS));
|
||||||
|
register_builtin(BI_TEMPLATE, tmp_root.value);
|
||||||
|
|
||||||
|
/* Slot 1: Name */
|
||||||
|
_get_struct(tmp_root.value)->slots[SS(NAME)] = string_to_value("template");
|
||||||
|
/* Slot 2: Super/parent structure type, or NIL */
|
||||||
|
_get_struct(tmp_root.value)->slots[SS(SUPER)] = NIL;
|
||||||
|
/* Slot 3: Vector of slot names; size == total number of slots */
|
||||||
|
_get_struct(tmp_root.value)->slots[SS(SLOTS)] = make_vector(TEMPLATE_SLOTS, NIL);
|
||||||
|
{
|
||||||
|
gc_root_t vec_root;
|
||||||
|
register_gc_root(&vec_root, _get_struct(tmp_root.value)->slots[SS(SLOTS)]);
|
||||||
|
_get_vector(vec_root.value)->elements[TS(GLOBAL_VARS)] = string_to_value("global-vars");
|
||||||
|
_get_vector(vec_root.value)->elements[TS(INSTANCE_VARS)] = string_to_value("instance-vars");
|
||||||
|
_get_vector(vec_root.value)->elements[TS(FRAME_VARS)] = string_to_value("frame-vars");
|
||||||
|
_get_vector(vec_root.value)->elements[TS(BYTE_CODE)] = string_to_value("byte-code");
|
||||||
|
_get_vector(vec_root.value)->elements[TS(TAIL_CALL)] = string_to_value("tail-call");
|
||||||
|
_get_vector(vec_root.value)->elements[TS(ARG_LIST)] = string_to_value("argument-list");
|
||||||
|
_get_vector(vec_root.value)->elements[TS(CONTINUATION)] = string_to_value("continuation");
|
||||||
|
_get_vector(vec_root.value)->elements[TS(CONTEXT)] = string_to_value("context");
|
||||||
|
unregister_gc_root(&vec_root);
|
||||||
|
}
|
||||||
|
/* Slot 4: Callable object used as proxy when structure is apply'd. */
|
||||||
|
_get_struct(tmp_root.value)->slots[SS(CALLABLE)] = NIL;
|
||||||
|
|
||||||
|
unregister_gc_root(&tmp_root);
|
||||||
|
|
||||||
|
#undef TS
|
||||||
|
#define LS(x) LAMBDA_SLOT_ ## x
|
||||||
|
|
||||||
|
/* Lambda: Instances of this structure are fundamental callable objects. */
|
||||||
|
register_gc_root(&tmp_root, make_struct(ms_root.value, STRUCTURE_SLOTS));
|
||||||
|
register_builtin(BI_LAMBDA, tmp_root.value);
|
||||||
|
|
||||||
|
/* Slot 1: Name */
|
||||||
|
_get_struct(tmp_root.value)->slots[SS(NAME)] = string_to_value("lambda");
|
||||||
|
/* Slot 2: Super/parent structure type, or NIL */
|
||||||
|
_get_struct(tmp_root.value)->slots[SS(SUPER)] = NIL;
|
||||||
|
/* Slot 3: Vector of slot names; size == total number of slots */
|
||||||
|
_get_struct(tmp_root.value)->slots[SS(SLOTS)] = make_vector(LAMBDA_SLOTS, NIL);
|
||||||
|
{
|
||||||
|
gc_root_t vec_root;
|
||||||
|
register_gc_root(&vec_root, _get_struct(tmp_root.value)->slots[SS(SLOTS)]);
|
||||||
|
_get_vector(vec_root.value)->elements[LS(GLOBAL_VARS)] = string_to_value("global-vars");
|
||||||
|
_get_vector(vec_root.value)->elements[LS(INSTANCE_VARS)] = string_to_value("instance-vars");
|
||||||
|
_get_vector(vec_root.value)->elements[LS(FRAME_VARS)] = string_to_value("frame-vars");
|
||||||
|
_get_vector(vec_root.value)->elements[LS(BYTE_CODE)] = string_to_value("byte-code");
|
||||||
|
_get_vector(vec_root.value)->elements[LS(TAIL_CALL)] = string_to_value("tail-call");
|
||||||
|
_get_vector(vec_root.value)->elements[LS(ARG_LIST)] = string_to_value("argument-list");
|
||||||
|
_get_vector(vec_root.value)->elements[LS(CONTINUATION)] = string_to_value("continuation");
|
||||||
|
_get_vector(vec_root.value)->elements[LS(CONTEXT)] = string_to_value("context");
|
||||||
|
unregister_gc_root(&vec_root);
|
||||||
|
}
|
||||||
|
/* Slot 4: Callable object used as proxy when structure is apply'd. */
|
||||||
|
_get_struct(tmp_root.value)->slots[SS(CALLABLE)] = NIL;
|
||||||
|
|
||||||
|
unregister_gc_root(&tmp_root);
|
||||||
|
|
||||||
|
#undef LS
|
||||||
|
#undef SS
|
||||||
|
|
||||||
|
unregister_gc_root(&ms_root);
|
||||||
|
}
|
||||||
|
|
||||||
|
void register_builtin(const char *name, value_t value)
|
||||||
|
{
|
||||||
|
gc_root_t name_root;
|
||||||
|
|
||||||
|
register_gc_root(&name_root, string_to_value(name));
|
||||||
|
builtin_list.value = cons(value, builtin_list.value);
|
||||||
|
builtin_list.value = cons(name_root.value, builtin_list.value);
|
||||||
|
unregister_gc_root(&name_root);
|
||||||
|
}
|
||||||
|
|
||||||
|
value_t lookup_builtin(const char *name)
|
||||||
|
{
|
||||||
|
value_t name_val = string_to_value(name);
|
||||||
|
|
||||||
|
for (value_t list = builtin_list.value; !is_nil(list);
|
||||||
|
list = _CDDR(list))
|
||||||
|
{
|
||||||
|
if (byte_strcmp(_CAR(list), name_val) == 0)
|
||||||
|
{
|
||||||
|
return _CADR(list);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
return FALSE_VALUE;
|
||||||
|
}
|
||||||
|
|
||||||
|
static value_t string_to_value(const char *s)
|
||||||
|
{
|
||||||
|
size_t len = strlen(s);
|
||||||
|
value_t v = make_byte_string(len, '\0');
|
||||||
|
memcpy(_get_byte_string(v)->bytes, s, len);
|
||||||
|
return v;
|
||||||
|
}
|
||||||
|
|
||||||
|
static char *value_to_string(value_t v)
|
||||||
|
{
|
||||||
|
byte_string_t *str = get_byte_string(v);
|
||||||
|
char *s = (char*)malloc(str->size + 1);
|
||||||
|
|
||||||
|
memcpy(s, str->bytes, str->size);
|
||||||
|
s[str->size] = '\0';
|
||||||
|
|
||||||
|
return s;
|
||||||
|
}
|
||||||
|
|
||||||
|
static int byte_strcmp(value_t s1, value_t s2)
|
||||||
|
{
|
||||||
|
byte_string_t *str1 = get_byte_string(s1);
|
||||||
|
byte_string_t *str2 = get_byte_string(s2);
|
||||||
|
|
||||||
|
if (str1->size < str2->size)
|
||||||
|
return -1;
|
||||||
|
else if (str1->size > str2->size)
|
||||||
|
return 1;
|
||||||
|
else
|
||||||
|
return memcmp(str1->bytes, str2->bytes, str1->size);
|
||||||
|
}
|
||||||
|
|
||||||
|
/* vim:set sw=2 expandtab: */
|
||||||
|
|
@ -0,0 +1,46 @@
|
||||||
|
#ifndef BUILTIN_H_85dfb9ef1b9889cd01b60306e12f5e8e
|
||||||
|
#define BUILTIN_H_85dfb9ef1b9889cd01b60306e12f5e8e
|
||||||
|
|
||||||
|
#include <assert.h>
|
||||||
|
#include <inttypes.h>
|
||||||
|
#include <stdbool.h>
|
||||||
|
|
||||||
|
#include "gc.h"
|
||||||
|
|
||||||
|
/* Names of fundamental builtin values */
|
||||||
|
#define BI_STRUCTURE "structure"
|
||||||
|
#define BI_TEMPLATE "template"
|
||||||
|
#define BI_LAMBDA "lambda"
|
||||||
|
|
||||||
|
#define STRUCTURE_SLOT_NAME 0
|
||||||
|
#define STRUCTURE_SLOT_SUPER 1
|
||||||
|
#define STRUCTURE_SLOT_SLOTS 2
|
||||||
|
#define STRUCTURE_SLOT_CALLABLE 3
|
||||||
|
#define STRUCTURE_SLOTS 4
|
||||||
|
|
||||||
|
#define TEMPLATE_SLOT_GLOBAL_VARS 0
|
||||||
|
#define TEMPLATE_SLOT_INSTANCE_VARS 1
|
||||||
|
#define TEMPLATE_SLOT_FRAME_VARS 2
|
||||||
|
#define TEMPLATE_SLOT_BYTE_CODE 3
|
||||||
|
#define TEMPLATE_SLOT_TAIL_CALL 4
|
||||||
|
#define TEMPLATE_SLOT_ARG_LIST 5
|
||||||
|
#define TEMPLATE_SLOT_CONTINUATION 6
|
||||||
|
#define TEMPLATE_SLOT_CONTEXT 7
|
||||||
|
#define TEMPLATE_SLOTS 8
|
||||||
|
|
||||||
|
#define LAMBDA_SLOT_GLOBAL_VARS 0
|
||||||
|
#define LAMBDA_SLOT_INSTANCE_VARS 1
|
||||||
|
#define LAMBDA_SLOT_FRAME_VARS 2
|
||||||
|
#define LAMBDA_SLOT_BYTE_CODE 3
|
||||||
|
#define LAMBDA_SLOT_TAIL_CALL 4
|
||||||
|
#define LAMBDA_SLOT_ARG_LIST 5
|
||||||
|
#define LAMBDA_SLOT_CONTINUATION 6
|
||||||
|
#define LAMBDA_SLOT_CONTEXT 7
|
||||||
|
#define LAMBDA_SLOTS 8
|
||||||
|
|
||||||
|
void builtin_init(void);
|
||||||
|
void register_builtin(const char *name, value_t value);
|
||||||
|
value_t lookup_builtin(const char *name);
|
||||||
|
|
||||||
|
#endif
|
||||||
|
/* vim:set sw=2 expandtab: */
|
||||||
|
|
@ -125,8 +125,8 @@ in:
|
||||||
fN (1NNNNNNN) [frame, N < 120]
|
fN (1NNNNNNN) [frame, N < 120]
|
||||||
-- (11111NNN) [reserved, N < 5]
|
-- (11111NNN) [reserved, N < 5]
|
||||||
argv (11111101) [argument list]
|
argv (11111101) [argument list]
|
||||||
ctx (11111110) [dynamic context]
|
k (11111110) [continuation]
|
||||||
k (11111111) [continuation]
|
ctx (11111111) [dynamic context]
|
||||||
|
|
||||||
out:
|
out:
|
||||||
fN (1NNNNNNN) [0 <= N < 120]
|
fN (1NNNNNNN) [0 <= N < 120]
|
||||||
|
|
@ -138,8 +138,8 @@ lambda:[
|
||||||
code: byte-string containing sequence of 4-byte instruction words
|
code: byte-string containing sequence of 4-byte instruction words
|
||||||
tail-call: in-ref of lambda to tail-call
|
tail-call: in-ref of lambda to tail-call
|
||||||
arguments: in-ref of argument list to pass to tail-call
|
arguments: in-ref of argument list to pass to tail-call
|
||||||
context: in-ref of dynamic context to pass to tail-call
|
|
||||||
continuation: in-ref of continuation to pass to tail-call
|
continuation: in-ref of continuation to pass to tail-call
|
||||||
|
context: in-ref of dynamic context to pass to tail-call
|
||||||
]
|
]
|
||||||
|
|
||||||
template:[
|
template:[
|
||||||
|
|
@ -149,8 +149,8 @@ template:[
|
||||||
code: linked
|
code: linked
|
||||||
tail-call: copied verbatim
|
tail-call: copied verbatim
|
||||||
arguments: copied verbatim
|
arguments: copied verbatim
|
||||||
context: copied verbatim
|
|
||||||
continuation: copied verbatim
|
continuation: copied verbatim
|
||||||
|
context: copied verbatim
|
||||||
]
|
]
|
||||||
|
|
||||||
Protocol:
|
Protocol:
|
||||||
|
|
|
||||||
80
gc.c
80
gc.c
|
|
@ -1,3 +1,5 @@
|
||||||
|
#define _POSIX_C_SOURCE 199309L
|
||||||
|
|
||||||
#include <assert.h>
|
#include <assert.h>
|
||||||
#include <inttypes.h>
|
#include <inttypes.h>
|
||||||
#include <stdbool.h>
|
#include <stdbool.h>
|
||||||
|
|
@ -13,7 +15,7 @@ gc_stats_t gc_stats;
|
||||||
/* Helper macros to reduce duplication */
|
/* Helper macros to reduce duplication */
|
||||||
#define VECTOR_BYTES(nelem) (sizeof(vector_t) + (sizeof(value_t) * (nelem)))
|
#define VECTOR_BYTES(nelem) (sizeof(vector_t) + (sizeof(value_t) * (nelem)))
|
||||||
#define BYTESTR_BYTES(size) (sizeof(byte_string_t) + (size))
|
#define BYTESTR_BYTES(size) (sizeof(byte_string_t) + (size))
|
||||||
#define STRUCT_BYTES(nslots) VECTOR_BYTES(nslots)
|
#define STRUCT_BYTES(nslots) (sizeof(struct_t) + (sizeof(value_t) * (nslots)))
|
||||||
|
|
||||||
/* Alignment must ensure each object has enough room to hold a forwarding object */
|
/* Alignment must ensure each object has enough room to hold a forwarding object */
|
||||||
#define GC_ALIGNMENT ((size_t)(sizeof(object_t)))
|
#define GC_ALIGNMENT ((size_t)(sizeof(object_t)))
|
||||||
|
|
@ -182,20 +184,14 @@ value_t make_struct(value_t type, size_t nslots)
|
||||||
gc_root_t type_root;
|
gc_root_t type_root;
|
||||||
struct_t *s;
|
struct_t *s;
|
||||||
|
|
||||||
assert(nslots >= 1);
|
|
||||||
|
|
||||||
/* Ensure that there is always a slot for the type */
|
|
||||||
if (nslots < 1)
|
|
||||||
nslots = 1;
|
|
||||||
|
|
||||||
register_gc_root(&type_root, type);
|
register_gc_root(&type_root, type);
|
||||||
|
|
||||||
s = (struct_t*)gc_alloc(STRUCT_BYTES(nslots));
|
s = (struct_t*)gc_alloc(STRUCT_BYTES(nslots));
|
||||||
s->tag = TYPE_TAG_VECTOR;
|
s->tag = TYPE_TAG_STRUCT;
|
||||||
|
s->type = type_root.value;
|
||||||
s->nslots = nslots;
|
s->nslots = nslots;
|
||||||
s->slots[0] = type_root.value;
|
|
||||||
|
|
||||||
for (int i = 1; i < nslots; ++i)
|
for (int i = 0; i < nslots; ++i)
|
||||||
s->slots[i] = NIL;
|
s->slots[i] = NIL;
|
||||||
|
|
||||||
unregister_gc_root(&type_root);
|
unregister_gc_root(&type_root);
|
||||||
|
|
@ -275,7 +271,7 @@ static will_t *get_will(value_t v)
|
||||||
abort();
|
abort();
|
||||||
}
|
}
|
||||||
|
|
||||||
intptr_t get_fixnum(value_t v)
|
fixnum_t get_fixnum(value_t v)
|
||||||
{
|
{
|
||||||
if (is_fixnum(v))
|
if (is_fixnum(v))
|
||||||
return _get_fixnum(v);
|
return _get_fixnum(v);
|
||||||
|
|
@ -298,11 +294,11 @@ static inline size_t gc_align(size_t nbytes)
|
||||||
|
|
||||||
static int gc_range_of(void *object)
|
static int gc_range_of(void *object)
|
||||||
{
|
{
|
||||||
if (((uintptr_t)object >= (uintptr_t)gc_ranges[0]) &&
|
if (((value_t)object >= (value_t)gc_ranges[0]) &&
|
||||||
((uintptr_t)object < (uintptr_t)gc_ranges[1]))
|
((value_t)object < (value_t)gc_ranges[1]))
|
||||||
return 0;
|
return 0;
|
||||||
if (((uintptr_t)object >= (uintptr_t)gc_ranges[1]) &&
|
if (((value_t)object >= (value_t)gc_ranges[1]) &&
|
||||||
((uintptr_t)object < (uintptr_t)gc_ranges[2]))
|
((value_t)object < (value_t)gc_ranges[2]))
|
||||||
return 1;
|
return 1;
|
||||||
return -1;
|
return -1;
|
||||||
}
|
}
|
||||||
|
|
@ -330,8 +326,10 @@ void gc_init(size_t min_size, size_t max_size)
|
||||||
gc_range_end = gc_free_ptr + gc_soft_limit;
|
gc_range_end = gc_free_ptr + gc_soft_limit;
|
||||||
|
|
||||||
gc_stats.collections = 0;
|
gc_stats.collections = 0;
|
||||||
gc_stats.total_ticks = 0;
|
gc_stats.total_ns = 0;
|
||||||
|
gc_stats.total_freed = 0;
|
||||||
gc_stats.high_water = 0;
|
gc_stats.high_water = 0;
|
||||||
|
gc_stats.max_ns = 0;
|
||||||
|
|
||||||
gc_weak_box_list = NIL;
|
gc_weak_box_list = NIL;
|
||||||
gc_will_list = NIL;
|
gc_will_list = NIL;
|
||||||
|
|
@ -383,12 +381,14 @@ static void transfer_object(value_t *value)
|
||||||
switch (obj->tag)
|
switch (obj->tag)
|
||||||
{
|
{
|
||||||
case TYPE_TAG_VECTOR:
|
case TYPE_TAG_VECTOR:
|
||||||
case TYPE_TAG_STRUCT:
|
|
||||||
nbytes = VECTOR_BYTES(((const vector_t*)obj)->size);
|
nbytes = VECTOR_BYTES(((const vector_t*)obj)->size);
|
||||||
break;
|
break;
|
||||||
case TYPE_TAG_BYTESTR:
|
case TYPE_TAG_BYTESTR:
|
||||||
nbytes = BYTESTR_BYTES(((const byte_string_t*)obj)->size);
|
nbytes = BYTESTR_BYTES(((const byte_string_t*)obj)->size);
|
||||||
break;
|
break;
|
||||||
|
case TYPE_TAG_STRUCT:
|
||||||
|
nbytes = STRUCT_BYTES(((const struct_t*)obj)->nslots);
|
||||||
|
break;
|
||||||
case TYPE_TAG_WEAK_BOX:
|
case TYPE_TAG_WEAK_BOX:
|
||||||
nbytes = sizeof(weak_box_t);
|
nbytes = sizeof(weak_box_t);
|
||||||
break;
|
break;
|
||||||
|
|
@ -415,7 +415,6 @@ static void transfer_object(value_t *value)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
/* Also works on structs, which share the same layout */
|
|
||||||
static size_t transfer_vector(vector_t *vec)
|
static size_t transfer_vector(vector_t *vec)
|
||||||
{
|
{
|
||||||
for (size_t i = 0; i < vec->size; ++i)
|
for (size_t i = 0; i < vec->size; ++i)
|
||||||
|
|
@ -424,6 +423,16 @@ static size_t transfer_vector(vector_t *vec)
|
||||||
return VECTOR_BYTES(vec->size);
|
return VECTOR_BYTES(vec->size);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
static size_t transfer_struct(struct_t *s)
|
||||||
|
{
|
||||||
|
transfer_object(&s->type);
|
||||||
|
|
||||||
|
for (size_t i = 0; i < s->nslots; ++i)
|
||||||
|
transfer_object(&s->slots[i]);
|
||||||
|
|
||||||
|
return STRUCT_BYTES(s->nslots);
|
||||||
|
}
|
||||||
|
|
||||||
static size_t transfer_pair(pair_t *p)
|
static size_t transfer_pair(pair_t *p)
|
||||||
{
|
{
|
||||||
transfer_object(&p->car);
|
transfer_object(&p->car);
|
||||||
|
|
@ -447,10 +456,11 @@ static size_t transfer_children(object_t *obj)
|
||||||
switch (obj->tag)
|
switch (obj->tag)
|
||||||
{
|
{
|
||||||
case TYPE_TAG_VECTOR:
|
case TYPE_TAG_VECTOR:
|
||||||
case TYPE_TAG_STRUCT:
|
|
||||||
return transfer_vector((vector_t*)obj);
|
return transfer_vector((vector_t*)obj);
|
||||||
case TYPE_TAG_BYTESTR:
|
case TYPE_TAG_BYTESTR:
|
||||||
return BYTESTR_BYTES(((const byte_string_t*)obj)->size);
|
return BYTESTR_BYTES(((const byte_string_t*)obj)->size);
|
||||||
|
case TYPE_TAG_STRUCT:
|
||||||
|
return transfer_struct((struct_t*)obj);
|
||||||
case TYPE_TAG_WEAK_BOX:
|
case TYPE_TAG_WEAK_BOX:
|
||||||
return sizeof(weak_box_t);
|
return sizeof(weak_box_t);
|
||||||
case TYPE_TAG_WILL:
|
case TYPE_TAG_WILL:
|
||||||
|
|
@ -567,18 +577,26 @@ static void process_wills(void)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
#define GC_DEFLATE_SIZE (64*1024)
|
||||||
|
|
||||||
static void update_soft_limit(size_t min_free)
|
static void update_soft_limit(size_t min_free)
|
||||||
{
|
{
|
||||||
size_t bytes_used = gc_free_ptr - gc_ranges[gc_current_range];
|
size_t bytes_used = gc_free_ptr - gc_ranges[gc_current_range];
|
||||||
size_t min_limit = bytes_used + min_free;
|
size_t min_limit = bytes_used + min_free;
|
||||||
size_t new_limit = (5 * min_limit) / 3;
|
size_t new_limit = (4 * min_limit) / 3;
|
||||||
|
|
||||||
if (new_limit > gc_max_size)
|
if (new_limit > gc_max_size)
|
||||||
new_limit = gc_max_size;
|
new_limit = gc_max_size;
|
||||||
#if 0
|
#if 1
|
||||||
else if (new_limit < gc_min_size)
|
else if (new_limit < gc_min_size)
|
||||||
new_limit = gc_min_size;
|
new_limit = gc_min_size;
|
||||||
|
|
||||||
|
if (gc_soft_limit > GC_DEFLATE_SIZE)
|
||||||
|
{
|
||||||
|
if (new_limit < (gc_soft_limit - GC_DEFLATE_SIZE))
|
||||||
|
new_limit = gc_soft_limit - GC_DEFLATE_SIZE;
|
||||||
|
}
|
||||||
|
|
||||||
gc_soft_limit = new_limit;
|
gc_soft_limit = new_limit;
|
||||||
#else
|
#else
|
||||||
if (new_limit > gc_soft_limit)
|
if (new_limit > gc_soft_limit)
|
||||||
|
|
@ -598,9 +616,11 @@ static void _collect_garbage(size_t min_free)
|
||||||
{
|
{
|
||||||
if (gc_enabled)
|
if (gc_enabled)
|
||||||
{
|
{
|
||||||
|
struct timespec start_time;
|
||||||
char *object_ptr;
|
char *object_ptr;
|
||||||
|
|
||||||
gc_stats.total_ticks -= clock();
|
clock_gettime(CLOCK_MONOTONIC, &start_time);
|
||||||
|
gc_stats.total_freed -= gc_free_space();
|
||||||
++gc_stats.collections;
|
++gc_stats.collections;
|
||||||
|
|
||||||
//debug(("Collecting garbage...\n"));
|
//debug(("Collecting garbage...\n"));
|
||||||
|
|
@ -632,7 +652,21 @@ static void _collect_garbage(size_t min_free)
|
||||||
|
|
||||||
//debug(("Finished collection with %d bytes to spare (out of %d bytes).\n", gc_free_space(), gc_soft_limit));
|
//debug(("Finished collection with %d bytes to spare (out of %d bytes).\n", gc_free_space(), gc_soft_limit));
|
||||||
|
|
||||||
gc_stats.total_ticks += clock();
|
{
|
||||||
|
struct timespec end_time;
|
||||||
|
nsec_t nsec;
|
||||||
|
|
||||||
|
clock_gettime(CLOCK_MONOTONIC, &end_time);
|
||||||
|
|
||||||
|
nsec = (end_time.tv_sec - start_time.tv_sec) * 1000000000LL;
|
||||||
|
nsec += (end_time.tv_nsec - start_time.tv_nsec);
|
||||||
|
|
||||||
|
gc_stats.total_ns += nsec;
|
||||||
|
gc_stats.total_freed += gc_free_space();
|
||||||
|
|
||||||
|
if (nsec > gc_stats.max_ns)
|
||||||
|
gc_stats.max_ns = nsec;
|
||||||
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
update_soft_limit(min_free);
|
update_soft_limit(min_free);
|
||||||
|
|
|
||||||
37
gc.h
37
gc.h
|
|
@ -5,6 +5,7 @@
|
||||||
#include <inttypes.h>
|
#include <inttypes.h>
|
||||||
#include <stdbool.h>
|
#include <stdbool.h>
|
||||||
#include <stdio.h>
|
#include <stdio.h>
|
||||||
|
#include <time.h>
|
||||||
|
|
||||||
#ifndef NDEBUG
|
#ifndef NDEBUG
|
||||||
# define debug(printf_args) ((void)printf printf_args)
|
# define debug(printf_args) ((void)printf printf_args)
|
||||||
|
|
@ -13,6 +14,7 @@
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
typedef uintptr_t value_t;
|
typedef uintptr_t value_t;
|
||||||
|
typedef intptr_t fixnum_t;
|
||||||
|
|
||||||
/* NIL: 00000000 00000000 00000000 00000000 */
|
/* NIL: 00000000 00000000 00000000 00000000 */
|
||||||
/* Object: aaaaaaaa aaaaaaaa aaaaaaaa aaaaaa00 (where aa... >= 1024) */
|
/* Object: aaaaaaaa aaaaaaaa aaaaaaaa aaaaaa00 (where aa... >= 1024) */
|
||||||
|
|
@ -38,6 +40,16 @@ typedef uintptr_t value_t;
|
||||||
#define TYPE_TAG_WEAK_BOX TYPE_TAG(4)
|
#define TYPE_TAG_WEAK_BOX TYPE_TAG(4)
|
||||||
#define TYPE_TAG_WILL TYPE_TAG(5)
|
#define TYPE_TAG_WILL TYPE_TAG(5)
|
||||||
|
|
||||||
|
#define CAR(x) (get_pair(x)->car)
|
||||||
|
#define CDR(x) (get_pair(x)->cdr)
|
||||||
|
#define CADR(x) CAR(CDR(x))
|
||||||
|
#define CDDR(x) CDR(CDR(x))
|
||||||
|
|
||||||
|
#define _CAR(x) (_get_pair(x)->car)
|
||||||
|
#define _CDR(x) (_get_pair(x)->cdr)
|
||||||
|
#define _CADR(x) _CAR(_CDR(x))
|
||||||
|
#define _CDDR(x) _CDR(_CDR(x))
|
||||||
|
|
||||||
typedef struct object
|
typedef struct object
|
||||||
{
|
{
|
||||||
value_t tag;
|
value_t tag;
|
||||||
|
|
@ -75,7 +87,8 @@ typedef struct byte_string
|
||||||
typedef struct structure
|
typedef struct structure
|
||||||
{
|
{
|
||||||
value_t tag; /* TYPE_TAG_STRUCT */
|
value_t tag; /* TYPE_TAG_STRUCT */
|
||||||
size_t nslots; /* Includes slots[0], the struct subtype */
|
value_t type;
|
||||||
|
size_t nslots;
|
||||||
value_t slots[0];
|
value_t slots[0];
|
||||||
} struct_t;
|
} struct_t;
|
||||||
|
|
||||||
|
|
@ -101,11 +114,15 @@ typedef struct gc_root
|
||||||
struct gc_root *next;
|
struct gc_root *next;
|
||||||
} gc_root_t;
|
} gc_root_t;
|
||||||
|
|
||||||
|
typedef uint64_t nsec_t;
|
||||||
|
|
||||||
typedef struct gc_stats
|
typedef struct gc_stats
|
||||||
{
|
{
|
||||||
int collections;
|
int collections;
|
||||||
clock_t total_ticks;
|
nsec_t total_ns;
|
||||||
|
uint64_t total_freed;
|
||||||
size_t high_water;
|
size_t high_water;
|
||||||
|
nsec_t max_ns;
|
||||||
} gc_stats_t;
|
} gc_stats_t;
|
||||||
|
|
||||||
extern gc_stats_t gc_stats;
|
extern gc_stats_t gc_stats;
|
||||||
|
|
@ -124,8 +141,7 @@ vector_t *get_vector(value_t v);
|
||||||
value_t make_byte_string(size_t size, int default_value);
|
value_t make_byte_string(size_t size, int default_value);
|
||||||
byte_string_t *get_byte_string(value_t v);
|
byte_string_t *get_byte_string(value_t v);
|
||||||
|
|
||||||
/* Precondition: slots >= 1; this includes the struct type tag, slots[0]. */
|
value_t make_struct(value_t type, size_t nslots);
|
||||||
value_t make_struct(value_t type, size_t slots);
|
|
||||||
struct_t *get_struct(value_t v);
|
struct_t *get_struct(value_t v);
|
||||||
|
|
||||||
value_t make_weak_box(value_t value);
|
value_t make_weak_box(value_t value);
|
||||||
|
|
@ -138,7 +154,7 @@ bool are_finalizers_pending(void);
|
||||||
/* If *value == #f on return there are no more finalizers. */
|
/* If *value == #f on return there are no more finalizers. */
|
||||||
void get_next_finalizer(value_t *value, value_t *finalizer);
|
void get_next_finalizer(value_t *value, value_t *finalizer);
|
||||||
|
|
||||||
intptr_t get_fixnum(value_t v);
|
fixnum_t get_fixnum(value_t v);
|
||||||
|
|
||||||
/****************************************************************************/
|
/****************************************************************************/
|
||||||
|
|
||||||
|
|
@ -253,11 +269,6 @@ static inline struct_t *_get_struct(value_t v)
|
||||||
return (struct_t*)_get_object(v);
|
return (struct_t*)_get_object(v);
|
||||||
}
|
}
|
||||||
|
|
||||||
static inline size_t struct_type(value_t v)
|
|
||||||
{
|
|
||||||
return get_struct(v)->slots[0];
|
|
||||||
}
|
|
||||||
|
|
||||||
static inline bool is_weak_box(value_t v)
|
static inline bool is_weak_box(value_t v)
|
||||||
{
|
{
|
||||||
return is_object(v) && (_get_object(v)->tag == TYPE_TAG_WEAK_BOX);
|
return is_object(v) && (_get_object(v)->tag == TYPE_TAG_WEAK_BOX);
|
||||||
|
|
@ -278,14 +289,14 @@ static inline bool is_fixnum(value_t v)
|
||||||
return (v & 1) != 0;
|
return (v & 1) != 0;
|
||||||
}
|
}
|
||||||
|
|
||||||
static inline value_t make_fixnum(intptr_t n)
|
static inline value_t make_fixnum(fixnum_t n)
|
||||||
{
|
{
|
||||||
return (value_t)(n << 1) | 1;
|
return (value_t)(n << 1) | 1;
|
||||||
}
|
}
|
||||||
|
|
||||||
static inline intptr_t _get_fixnum(value_t n)
|
static inline fixnum_t _get_fixnum(value_t n)
|
||||||
{
|
{
|
||||||
return ((intptr_t)n) >> 1;
|
return ((fixnum_t)n) >> 1;
|
||||||
}
|
}
|
||||||
|
|
||||||
void gc_init(size_t min_size, size_t max_size);
|
void gc_init(size_t min_size, size_t max_size);
|
||||||
|
|
|
||||||
239
gc_test.c
239
gc_test.c
|
|
@ -1,239 +0,0 @@
|
||||||
#include <sys/time.h>
|
|
||||||
|
|
||||||
#include <inttypes.h>
|
|
||||||
#include <stdbool.h>
|
|
||||||
#include <stdio.h>
|
|
||||||
#include <stdlib.h>
|
|
||||||
#include <string.h>
|
|
||||||
#include <time.h>
|
|
||||||
|
|
||||||
#include "gc.h"
|
|
||||||
|
|
||||||
void out_of_memory(void)
|
|
||||||
{
|
|
||||||
fprintf(stderr, "Out of memory!\n");
|
|
||||||
abort();
|
|
||||||
}
|
|
||||||
|
|
||||||
static void print_value(value_t v);
|
|
||||||
static inline void comma(void) { fputs(", ", stdout); }
|
|
||||||
static inline void nl(void) { putchar('\n'); }
|
|
||||||
|
|
||||||
int main(int argc, char **argv)
|
|
||||||
{
|
|
||||||
gc_root_t list_root, tmp_root;
|
|
||||||
int count = 0;
|
|
||||||
|
|
||||||
gc_init(1024, 256*1024*1024);
|
|
||||||
|
|
||||||
srand((unsigned int)time(NULL));
|
|
||||||
|
|
||||||
register_gc_root(&list_root, NIL);
|
|
||||||
register_gc_root(&tmp_root, NIL);
|
|
||||||
|
|
||||||
tmp_root.value = cons(make_fixnum(1), cons(make_fixnum(2), NIL));
|
|
||||||
list_root.value = make_weak_box(tmp_root.value);
|
|
||||||
|
|
||||||
register_finalizer(tmp_root.value, make_fixnum(10));
|
|
||||||
|
|
||||||
print_value(list_root.value); comma();
|
|
||||||
{
|
|
||||||
value_t v, f;
|
|
||||||
|
|
||||||
get_next_finalizer(&v, &f);
|
|
||||||
|
|
||||||
print_value(v); comma();
|
|
||||||
print_value(f); nl(); nl();
|
|
||||||
}
|
|
||||||
|
|
||||||
collect_garbage(0);
|
|
||||||
|
|
||||||
print_value(list_root.value); comma();
|
|
||||||
{
|
|
||||||
value_t v, f;
|
|
||||||
|
|
||||||
get_next_finalizer(&v, &f);
|
|
||||||
|
|
||||||
print_value(v); comma();
|
|
||||||
print_value(f); nl(); nl();
|
|
||||||
}
|
|
||||||
|
|
||||||
tmp_root.value = NIL;
|
|
||||||
|
|
||||||
print_value(list_root.value); comma();
|
|
||||||
{
|
|
||||||
value_t v, f;
|
|
||||||
|
|
||||||
get_next_finalizer(&v, &f);
|
|
||||||
|
|
||||||
print_value(v); comma();
|
|
||||||
print_value(f); nl(); nl();
|
|
||||||
}
|
|
||||||
|
|
||||||
collect_garbage(0);
|
|
||||||
|
|
||||||
print_value(list_root.value); comma();
|
|
||||||
{
|
|
||||||
value_t v, f;
|
|
||||||
|
|
||||||
get_next_finalizer(&v, &f);
|
|
||||||
|
|
||||||
print_value(v); comma();
|
|
||||||
print_value(f); nl(); nl();
|
|
||||||
}
|
|
||||||
|
|
||||||
#if 0
|
|
||||||
while (1)
|
|
||||||
{
|
|
||||||
int r = rand() & 0x3fff;
|
|
||||||
|
|
||||||
if (r == 0)
|
|
||||||
list_root.value = make_fixnum(rand());
|
|
||||||
else
|
|
||||||
{
|
|
||||||
switch (r & 7)
|
|
||||||
{
|
|
||||||
case 0:
|
|
||||||
list_root.value = cons(make_fixnum(rand()), list_root.value);
|
|
||||||
break;
|
|
||||||
case 1:
|
|
||||||
list_root.value = cons(list_root.value, make_byte_string(256, '\0'));
|
|
||||||
break;
|
|
||||||
case 2:
|
|
||||||
list_root.value = make_box(list_root.value);
|
|
||||||
break;
|
|
||||||
case 3:
|
|
||||||
list_root.value = cons(list_root.value, cons(make_fixnum(-1), NIL));
|
|
||||||
get_pair(get_pair(list_root.value)->cdr)->cdr = list_root.value;
|
|
||||||
break;
|
|
||||||
case 4:
|
|
||||||
case 5:
|
|
||||||
case 6:
|
|
||||||
case 7:
|
|
||||||
{
|
|
||||||
value_t s = make_struct(NIL, 5);
|
|
||||||
_get_struct(s)->slots[1+(r & 3)] = list_root.value;
|
|
||||||
list_root.value = s;
|
|
||||||
}
|
|
||||||
break;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
if (++count >= 10000000)
|
|
||||||
{
|
|
||||||
const double total_time = gc_stats.total_ticks / (double)CLOCKS_PER_SEC;
|
|
||||||
|
|
||||||
fprintf(stderr, "%0.3f sec / %d GCs => %0.3f usec/GC; peak was %u bytes.\n",
|
|
||||||
total_time,
|
|
||||||
gc_stats.collections,
|
|
||||||
(1000000 * total_time) / gc_stats.collections,
|
|
||||||
gc_stats.high_water);
|
|
||||||
|
|
||||||
gc_stats.collections = 0;
|
|
||||||
gc_stats.total_ticks = 0;
|
|
||||||
gc_stats.high_water = 0;
|
|
||||||
count = 0;
|
|
||||||
|
|
||||||
break;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
#endif
|
|
||||||
|
|
||||||
unregister_gc_root(&list_root);
|
|
||||||
|
|
||||||
return 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
static void print_value(value_t v)
|
|
||||||
{
|
|
||||||
if (v == NIL)
|
|
||||||
{
|
|
||||||
fputs("nil", stdout);
|
|
||||||
}
|
|
||||||
else if (v == FALSE_VALUE)
|
|
||||||
{
|
|
||||||
fputs("#f", stdout);
|
|
||||||
}
|
|
||||||
else if (v == TRUE_VALUE)
|
|
||||||
{
|
|
||||||
fputs("#t", stdout);
|
|
||||||
}
|
|
||||||
else if (is_fixnum(v))
|
|
||||||
{
|
|
||||||
printf("%d", (int)get_fixnum(v));
|
|
||||||
}
|
|
||||||
else if (is_box(v))
|
|
||||||
{
|
|
||||||
fputs("#&", stdout);
|
|
||||||
print_value(_get_box(v)->value);
|
|
||||||
}
|
|
||||||
else if (is_pair(v))
|
|
||||||
{
|
|
||||||
putchar('(');
|
|
||||||
|
|
||||||
print_value(_get_pair(v)->car);
|
|
||||||
v = _get_pair(v)->cdr;
|
|
||||||
|
|
||||||
while (is_pair(v))
|
|
||||||
{
|
|
||||||
putchar(' ');
|
|
||||||
print_value(_get_pair(v)->car);
|
|
||||||
v = _get_pair(v)->cdr;
|
|
||||||
}
|
|
||||||
|
|
||||||
if (v != NIL)
|
|
||||||
{
|
|
||||||
fputs(" . ", stdout);
|
|
||||||
print_value(v);
|
|
||||||
}
|
|
||||||
|
|
||||||
putchar(')');
|
|
||||||
}
|
|
||||||
else if (is_vector(v))
|
|
||||||
{
|
|
||||||
fputs("#(", stdout);
|
|
||||||
|
|
||||||
for (size_t i = 0; i < _get_vector(v)->size; ++i)
|
|
||||||
{
|
|
||||||
if (i != 0) putchar(' ');
|
|
||||||
print_value(_get_vector(v)->elements[i]);
|
|
||||||
}
|
|
||||||
|
|
||||||
putchar(')');
|
|
||||||
}
|
|
||||||
else if (is_byte_string(v))
|
|
||||||
{
|
|
||||||
fputs("#B(", stdout);
|
|
||||||
|
|
||||||
for (size_t i = 0; i < _get_byte_string(v)->size; ++i)
|
|
||||||
{
|
|
||||||
if (i != 0) putchar(' ');
|
|
||||||
printf("%d", (int)_get_byte_string(v)->bytes[i]);
|
|
||||||
}
|
|
||||||
|
|
||||||
putchar(')');
|
|
||||||
}
|
|
||||||
else if (is_struct(v))
|
|
||||||
{
|
|
||||||
fputs("#S(", stdout);
|
|
||||||
|
|
||||||
for (size_t i = 0; i < _get_struct(v)->nslots; ++i)
|
|
||||||
{
|
|
||||||
if (i != 0) putchar(' ');
|
|
||||||
print_value(_get_struct(v)->slots[i]);
|
|
||||||
}
|
|
||||||
|
|
||||||
putchar(')');
|
|
||||||
}
|
|
||||||
else if (is_weak_box(v))
|
|
||||||
{
|
|
||||||
fputs("#W&", stdout);
|
|
||||||
print_value(_get_weak_box(v)->value);
|
|
||||||
}
|
|
||||||
else
|
|
||||||
{
|
|
||||||
fputs("#<unknown>", stdout);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
/* vim:set sw=2 expandtab: */
|
|
||||||
|
|
@ -0,0 +1,233 @@
|
||||||
|
#include <inttypes.h>
|
||||||
|
#include <stdbool.h>
|
||||||
|
#include <stdlib.h>
|
||||||
|
|
||||||
|
#include "builtin.h"
|
||||||
|
#include "gc.h"
|
||||||
|
|
||||||
|
/* Ex: _SLOT_VALUE(STRUCTURE, v, NAME) */
|
||||||
|
#define _SLOT_VALUE(t,v,s) (_get_struct(v)->slots[t ## _SLOT_ ## s])
|
||||||
|
#define _LAMBDA_SLOT(v,s) _SLOT_VALUE(LAMBDA, v, s)
|
||||||
|
|
||||||
|
typedef struct interp_state
|
||||||
|
{
|
||||||
|
gc_root_t lambda;
|
||||||
|
gc_root_t frame;
|
||||||
|
gc_root_t argv;
|
||||||
|
gc_root_t k;
|
||||||
|
gc_root_t ctx;
|
||||||
|
} interp_state_t;
|
||||||
|
|
||||||
|
/* Quick references to main builtins */
|
||||||
|
static gc_root_t structure_type_root;
|
||||||
|
static gc_root_t template_type_root;
|
||||||
|
static gc_root_t lambda_type_root;
|
||||||
|
|
||||||
|
/* Local helper routines */
|
||||||
|
static bool struct_is_a(value_t s, value_t type);
|
||||||
|
static void translate_callable(interp_state_t *state);
|
||||||
|
static void run_byte_code(interp_state_t *state);
|
||||||
|
static void perform_tail_call(interp_state_t *state);
|
||||||
|
static value_t get_input(const interp_state_t *state, fixnum_t var);
|
||||||
|
static void set_output(const interp_state_t *state, fixnum_t var, value_t val);
|
||||||
|
static void register_state(interp_state_t *state, value_t lambda, value_t argv);
|
||||||
|
static void unregister_state(interp_state_t *state);
|
||||||
|
|
||||||
|
void interpreter_init(void)
|
||||||
|
{
|
||||||
|
register_gc_root(&structure_type_root, lookup_builtin(BI_STRUCTURE));
|
||||||
|
register_gc_root(&template_type_root, lookup_builtin(BI_TEMPLATE));
|
||||||
|
register_gc_root(&lambda_type_root, lookup_builtin(BI_LAMBDA));
|
||||||
|
}
|
||||||
|
|
||||||
|
value_t run_interpreter(value_t lambda, value_t argv)
|
||||||
|
{
|
||||||
|
static bool run_finalizers = true;
|
||||||
|
interp_state_t state;
|
||||||
|
|
||||||
|
register_state(&state, lambda, argv);
|
||||||
|
|
||||||
|
/* Keep going until something attempt to tail-call NIL, the original 'k', indicating completion. */
|
||||||
|
while (!is_nil(state.lambda.value))
|
||||||
|
{
|
||||||
|
/* 'lambda' may be a callable structure; if so, follow the 'callable' proxies and update argv. */
|
||||||
|
translate_callable(&state);
|
||||||
|
|
||||||
|
/*
|
||||||
|
* Now 'lambda' really is a lambda structure instance.
|
||||||
|
*/
|
||||||
|
|
||||||
|
/* Allocate frame variables */
|
||||||
|
state.frame.value = make_vector(get_fixnum(_LAMBDA_SLOT(state.lambda.value, FRAME_VARS)), NIL);
|
||||||
|
|
||||||
|
run_byte_code(&state);
|
||||||
|
perform_tail_call(&state);
|
||||||
|
|
||||||
|
if (run_finalizers)
|
||||||
|
{
|
||||||
|
value_t v, f;
|
||||||
|
get_next_finalizer(&v, &f);
|
||||||
|
|
||||||
|
if (is_object(v))
|
||||||
|
{
|
||||||
|
gc_root_t f_root;
|
||||||
|
|
||||||
|
register_gc_root(&f_root, f);
|
||||||
|
run_finalizers = false;
|
||||||
|
|
||||||
|
/* Note that recursion is limited to a single level by the static variable. */
|
||||||
|
run_interpreter(f_root.value, cons(v, NIL));
|
||||||
|
|
||||||
|
run_finalizers = true;
|
||||||
|
unregister_gc_root(&f_root);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
unregister_state(&state);
|
||||||
|
|
||||||
|
/* The arguments passed to NIL continuation are the final return value. */
|
||||||
|
return state.argv.value;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* TODO: Check for cycles (besides 'structure') and permit derivatives of 'structure'. */
|
||||||
|
static bool struct_is_a(value_t s, value_t type)
|
||||||
|
{
|
||||||
|
/* To prevent unbounded loops w/ cyclic 'parent' links. */
|
||||||
|
int ttl = 256;
|
||||||
|
|
||||||
|
if (!is_struct(s))
|
||||||
|
return false;
|
||||||
|
|
||||||
|
for (value_t t = _get_struct(s)->type; t != type; t = _SLOT_VALUE(STRUCTURE, t, SUPER), --ttl)
|
||||||
|
{
|
||||||
|
if (is_nil(t))
|
||||||
|
return false;
|
||||||
|
|
||||||
|
if (get_struct(t)->type != structure_type_root.value)
|
||||||
|
abort();
|
||||||
|
|
||||||
|
if (ttl <= 0)
|
||||||
|
abort();
|
||||||
|
}
|
||||||
|
|
||||||
|
return true;
|
||||||
|
}
|
||||||
|
|
||||||
|
static void translate_callable(interp_state_t *state)
|
||||||
|
{
|
||||||
|
while (!struct_is_a(state->lambda.value, lambda_type_root.value))
|
||||||
|
{
|
||||||
|
if (!struct_is_a(get_struct(state->lambda.value)->type, structure_type_root.value))
|
||||||
|
abort();
|
||||||
|
|
||||||
|
/* Prepend structure instance to argument list, per proxy protocol. */
|
||||||
|
state->argv.value = cons(state->lambda.value, state->argv.value);
|
||||||
|
|
||||||
|
/* Follow link to next callable. */
|
||||||
|
state->lambda.value = _SLOT_VALUE(STRUCTURE, _get_struct(state->lambda.value)->type, CALLABLE);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
static void run_byte_code(interp_state_t *state)
|
||||||
|
{
|
||||||
|
/* TODO */
|
||||||
|
}
|
||||||
|
|
||||||
|
static void perform_tail_call(interp_state_t *state)
|
||||||
|
{
|
||||||
|
value_t new_lambda, new_argv, new_ctx, new_k;
|
||||||
|
|
||||||
|
new_lambda = get_input(state, get_fixnum(_LAMBDA_SLOT(state->lambda.value, TAIL_CALL)));
|
||||||
|
new_argv = get_input(state, get_fixnum(_LAMBDA_SLOT(state->lambda.value, ARG_LIST)));
|
||||||
|
new_k = get_input(state, get_fixnum(_LAMBDA_SLOT(state->lambda.value, CONTINUATION)));
|
||||||
|
new_ctx = get_input(state, get_fixnum(_LAMBDA_SLOT(state->lambda.value, CONTEXT)));
|
||||||
|
|
||||||
|
state->lambda.value = new_lambda;
|
||||||
|
state->argv.value = new_argv;
|
||||||
|
state->k.value = new_k;
|
||||||
|
state->ctx.value = new_ctx;
|
||||||
|
}
|
||||||
|
|
||||||
|
static value_t get_input(const interp_state_t *state, fixnum_t var)
|
||||||
|
{
|
||||||
|
if (var >= 256)
|
||||||
|
abort();
|
||||||
|
else if (var == 255)
|
||||||
|
return state->ctx.value;
|
||||||
|
else if (var == 254)
|
||||||
|
return state->k.value;
|
||||||
|
else if (var == 253)
|
||||||
|
return state->argv.value;
|
||||||
|
else if (var >= 248)
|
||||||
|
abort(); /* reserved */
|
||||||
|
else if (var >= 128)
|
||||||
|
{
|
||||||
|
vector_t *vec = _get_vector(state->frame.value);
|
||||||
|
var -= 128;
|
||||||
|
|
||||||
|
if (var >= vec->size)
|
||||||
|
abort();
|
||||||
|
|
||||||
|
return vec->elements[var];
|
||||||
|
}
|
||||||
|
else if (var >= 64)
|
||||||
|
{
|
||||||
|
vector_t *vec = get_vector(_LAMBDA_SLOT(state->lambda.value, INSTANCE_VARS));
|
||||||
|
var -= 64;
|
||||||
|
|
||||||
|
if (var >= vec->size)
|
||||||
|
abort();
|
||||||
|
|
||||||
|
return vec->elements[var];
|
||||||
|
}
|
||||||
|
else if (var >= 1)
|
||||||
|
{
|
||||||
|
vector_t *vec = get_vector(_LAMBDA_SLOT(state->lambda.value, GLOBAL_VARS));
|
||||||
|
var -= 1;
|
||||||
|
|
||||||
|
if (var >= vec->size)
|
||||||
|
abort();
|
||||||
|
|
||||||
|
return vec->elements[var];
|
||||||
|
}
|
||||||
|
else if (var == 0)
|
||||||
|
return NIL;
|
||||||
|
else
|
||||||
|
abort();
|
||||||
|
}
|
||||||
|
|
||||||
|
static void set_output(const interp_state_t *state, fixnum_t var, value_t val)
|
||||||
|
{
|
||||||
|
vector_t *vec = _get_vector(state->frame.value);
|
||||||
|
|
||||||
|
if (var < 128)
|
||||||
|
abort();
|
||||||
|
|
||||||
|
var -= 128;
|
||||||
|
|
||||||
|
if (var >= vec->size)
|
||||||
|
abort();
|
||||||
|
|
||||||
|
vec->elements[var] = val;
|
||||||
|
}
|
||||||
|
|
||||||
|
static void register_state(interp_state_t *state, value_t lambda, value_t argv)
|
||||||
|
{
|
||||||
|
register_gc_root(&state->lambda, lambda);
|
||||||
|
register_gc_root(&state->frame, NIL);
|
||||||
|
register_gc_root(&state->argv, argv);
|
||||||
|
register_gc_root(&state->k, NIL);
|
||||||
|
register_gc_root(&state->ctx, NIL);
|
||||||
|
}
|
||||||
|
|
||||||
|
static void unregister_state(interp_state_t *state)
|
||||||
|
{
|
||||||
|
unregister_gc_root(&state->lambda);
|
||||||
|
unregister_gc_root(&state->frame);
|
||||||
|
unregister_gc_root(&state->argv);
|
||||||
|
unregister_gc_root(&state->k);
|
||||||
|
unregister_gc_root(&state->ctx);
|
||||||
|
}
|
||||||
|
|
||||||
|
/* vim:set sw=2 expandtab: */
|
||||||
|
|
@ -0,0 +1,10 @@
|
||||||
|
#ifndef INTERP_H_9c7eea5c5cd0f7a32b79a8ca0ab2969f
|
||||||
|
#define INTERP_H_9c7eea5c5cd0f7a32b79a8ca0ab2969f
|
||||||
|
|
||||||
|
#include "gc.h"
|
||||||
|
|
||||||
|
void interpreter_init(void);
|
||||||
|
value_t run_interpreter(value_t lambda, value_t argv);
|
||||||
|
|
||||||
|
#endif
|
||||||
|
/* vim:set sw=2 expandtab: */
|
||||||
|
|
@ -0,0 +1,285 @@
|
||||||
|
#include <sys/time.h>
|
||||||
|
|
||||||
|
#include <ctype.h>
|
||||||
|
#include <inttypes.h>
|
||||||
|
#include <stdbool.h>
|
||||||
|
#include <stdio.h>
|
||||||
|
#include <stdlib.h>
|
||||||
|
#include <string.h>
|
||||||
|
#include <time.h>
|
||||||
|
|
||||||
|
#include "gc.h"
|
||||||
|
#include "builtin.h"
|
||||||
|
#include "interp.h"
|
||||||
|
|
||||||
|
static void test_builtins(void);
|
||||||
|
static void test_weak_boxes_and_wills(void);
|
||||||
|
static void test_garbage_collection(void);
|
||||||
|
static void print_value(value_t v);
|
||||||
|
static void print_gc_stats(void);
|
||||||
|
|
||||||
|
static inline void comma(void) { fputs(", ", stdout); }
|
||||||
|
static inline void nl(void) { putchar('\n'); }
|
||||||
|
|
||||||
|
void out_of_memory(void)
|
||||||
|
{
|
||||||
|
fprintf(stderr, "Out of memory!\n\n");
|
||||||
|
print_gc_stats();
|
||||||
|
abort();
|
||||||
|
}
|
||||||
|
|
||||||
|
int main(int argc, char **argv)
|
||||||
|
{
|
||||||
|
srand((unsigned int)time(NULL));
|
||||||
|
|
||||||
|
gc_init(1024, 256*1024*1024);
|
||||||
|
|
||||||
|
builtin_init();
|
||||||
|
interpreter_init();
|
||||||
|
|
||||||
|
test_builtins();
|
||||||
|
test_weak_boxes_and_wills();
|
||||||
|
test_garbage_collection();
|
||||||
|
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
static void test_builtins(void)
|
||||||
|
{
|
||||||
|
print_value(lookup_builtin(BI_STRUCTURE)); nl(); nl();
|
||||||
|
print_value(lookup_builtin(BI_TEMPLATE)); nl(); nl();
|
||||||
|
print_value(lookup_builtin(BI_LAMBDA)); nl(); nl();
|
||||||
|
}
|
||||||
|
|
||||||
|
static void print_weak_box_results(value_t box)
|
||||||
|
{
|
||||||
|
value_t v, f;
|
||||||
|
print_value(box); comma();
|
||||||
|
get_next_finalizer(&v, &f);
|
||||||
|
print_value(v); comma(); print_value(f); nl();
|
||||||
|
}
|
||||||
|
|
||||||
|
static void test_weak_boxes_and_wills(void)
|
||||||
|
{
|
||||||
|
gc_root_t box_root, tmp_root;
|
||||||
|
|
||||||
|
register_gc_root(&box_root, NIL);
|
||||||
|
register_gc_root(&tmp_root, NIL);
|
||||||
|
|
||||||
|
tmp_root.value = cons(make_fixnum(1), cons(make_fixnum(2), NIL));
|
||||||
|
box_root.value = make_weak_box(tmp_root.value);
|
||||||
|
|
||||||
|
register_finalizer(tmp_root.value, make_fixnum(10));
|
||||||
|
print_weak_box_results(box_root.value);
|
||||||
|
|
||||||
|
collect_garbage(0);
|
||||||
|
print_weak_box_results(box_root.value);
|
||||||
|
|
||||||
|
tmp_root.value = NIL;
|
||||||
|
print_weak_box_results(box_root.value);
|
||||||
|
|
||||||
|
collect_garbage(0);
|
||||||
|
print_weak_box_results(box_root.value);
|
||||||
|
|
||||||
|
collect_garbage(0);
|
||||||
|
print_weak_box_results(box_root.value);
|
||||||
|
|
||||||
|
unregister_gc_root(&box_root);
|
||||||
|
unregister_gc_root(&tmp_root);
|
||||||
|
}
|
||||||
|
|
||||||
|
static void test_garbage_collection(void)
|
||||||
|
{
|
||||||
|
gc_root_t root;
|
||||||
|
int count = 0;
|
||||||
|
|
||||||
|
register_gc_root(&root, NIL);
|
||||||
|
|
||||||
|
while (1)
|
||||||
|
{
|
||||||
|
int r = rand() & 0xffff;
|
||||||
|
|
||||||
|
if (r == 0)
|
||||||
|
root.value = make_fixnum(rand());
|
||||||
|
else
|
||||||
|
{
|
||||||
|
switch (r & 7)
|
||||||
|
{
|
||||||
|
case 0:
|
||||||
|
root.value = cons(make_fixnum(rand()), root.value);
|
||||||
|
break;
|
||||||
|
case 1:
|
||||||
|
root.value = cons(root.value, make_byte_string(256, '\0'));
|
||||||
|
break;
|
||||||
|
case 2:
|
||||||
|
root.value = make_box(root.value);
|
||||||
|
break;
|
||||||
|
case 3:
|
||||||
|
root.value = cons(root.value, cons(make_fixnum(-1), NIL));
|
||||||
|
get_pair(get_pair(root.value)->cdr)->cdr = root.value;
|
||||||
|
break;
|
||||||
|
case 4:
|
||||||
|
case 5:
|
||||||
|
case 6:
|
||||||
|
case 7:
|
||||||
|
{
|
||||||
|
value_t s = make_struct(NIL, 4);
|
||||||
|
_get_struct(s)->slots[r & 3] = root.value;
|
||||||
|
root.value = s;
|
||||||
|
}
|
||||||
|
break;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
if (++count >= 50000000)
|
||||||
|
{
|
||||||
|
nl();
|
||||||
|
print_gc_stats();
|
||||||
|
|
||||||
|
gc_stats.collections = 0;
|
||||||
|
gc_stats.total_ns = 0;
|
||||||
|
gc_stats.total_freed = 0;
|
||||||
|
gc_stats.high_water = 0;
|
||||||
|
gc_stats.max_ns = 0;
|
||||||
|
count = 0;
|
||||||
|
|
||||||
|
break;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
unregister_gc_root(&root);
|
||||||
|
}
|
||||||
|
|
||||||
|
static bool all_print(const char *s, size_t len)
|
||||||
|
{
|
||||||
|
for (size_t i = 0; i < len; ++i)
|
||||||
|
{
|
||||||
|
if (s[i] == '"' || !isprint(s[i]))
|
||||||
|
return false;
|
||||||
|
}
|
||||||
|
return true;
|
||||||
|
}
|
||||||
|
|
||||||
|
static void print_value(value_t v)
|
||||||
|
{
|
||||||
|
if (v == NIL)
|
||||||
|
{
|
||||||
|
fputs("nil", stdout);
|
||||||
|
}
|
||||||
|
else if (v == FALSE_VALUE)
|
||||||
|
{
|
||||||
|
fputs("#f", stdout);
|
||||||
|
}
|
||||||
|
else if (v == TRUE_VALUE)
|
||||||
|
{
|
||||||
|
fputs("#t", stdout);
|
||||||
|
}
|
||||||
|
else if (is_fixnum(v))
|
||||||
|
{
|
||||||
|
printf("%d", (int)get_fixnum(v));
|
||||||
|
}
|
||||||
|
else if (is_box(v))
|
||||||
|
{
|
||||||
|
fputs("#&", stdout);
|
||||||
|
print_value(_get_box(v)->value);
|
||||||
|
}
|
||||||
|
else if (is_pair(v))
|
||||||
|
{
|
||||||
|
putchar('(');
|
||||||
|
|
||||||
|
print_value(_get_pair(v)->car);
|
||||||
|
v = _get_pair(v)->cdr;
|
||||||
|
|
||||||
|
while (is_pair(v))
|
||||||
|
{
|
||||||
|
putchar(' ');
|
||||||
|
print_value(_get_pair(v)->car);
|
||||||
|
v = _get_pair(v)->cdr;
|
||||||
|
}
|
||||||
|
|
||||||
|
if (v != NIL)
|
||||||
|
{
|
||||||
|
fputs(" . ", stdout);
|
||||||
|
print_value(v);
|
||||||
|
}
|
||||||
|
|
||||||
|
putchar(')');
|
||||||
|
}
|
||||||
|
else if (is_vector(v))
|
||||||
|
{
|
||||||
|
fputs("#(", stdout);
|
||||||
|
|
||||||
|
for (size_t i = 0; i < _get_vector(v)->size; ++i)
|
||||||
|
{
|
||||||
|
if (i != 0) putchar(' ');
|
||||||
|
print_value(_get_vector(v)->elements[i]);
|
||||||
|
}
|
||||||
|
|
||||||
|
putchar(')');
|
||||||
|
}
|
||||||
|
else if (is_byte_string(v))
|
||||||
|
{
|
||||||
|
byte_string_t *str = _get_byte_string(v);
|
||||||
|
|
||||||
|
if (all_print(str->bytes, str->size))
|
||||||
|
{
|
||||||
|
putchar('"');
|
||||||
|
fwrite(str->bytes, str->size, 1, stdout);
|
||||||
|
putchar('"');
|
||||||
|
}
|
||||||
|
else
|
||||||
|
{
|
||||||
|
fputs("#B(", stdout);
|
||||||
|
|
||||||
|
for (size_t i = 0; i < str->size; ++i)
|
||||||
|
{
|
||||||
|
if (i != 0) putchar(' ');
|
||||||
|
printf("%d", (int)str->bytes[i]);
|
||||||
|
}
|
||||||
|
|
||||||
|
putchar(')');
|
||||||
|
}
|
||||||
|
}
|
||||||
|
else if (is_struct(v))
|
||||||
|
{
|
||||||
|
struct_t *meta = get_struct(_get_struct(v)->type);
|
||||||
|
byte_string_t *str = get_byte_string(meta->slots[0]);
|
||||||
|
|
||||||
|
fputs("#S(", stdout);
|
||||||
|
fwrite(str->bytes, str->size, 1, stdout);
|
||||||
|
|
||||||
|
for (size_t i = 0; i < _get_struct(v)->nslots; ++i)
|
||||||
|
{
|
||||||
|
putchar(' ');
|
||||||
|
print_value(_get_struct(v)->slots[i]);
|
||||||
|
}
|
||||||
|
|
||||||
|
putchar(')');
|
||||||
|
}
|
||||||
|
else if (is_weak_box(v))
|
||||||
|
{
|
||||||
|
fputs("#W&", stdout);
|
||||||
|
print_value(_get_weak_box(v)->value);
|
||||||
|
}
|
||||||
|
else
|
||||||
|
{
|
||||||
|
fputs("#<unknown>", stdout);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
static void print_gc_stats(void)
|
||||||
|
{
|
||||||
|
const double total_time = gc_stats.total_ns / 1.0e9;
|
||||||
|
const double max_time = gc_stats.max_ns / 1.0e9;
|
||||||
|
|
||||||
|
fprintf(stderr, "%lld bytes freed in %0.6f sec => %0.3f MB/sec. (%d GCs.)\n",
|
||||||
|
gc_stats.total_freed,
|
||||||
|
total_time,
|
||||||
|
(gc_stats.total_freed / total_time) / (1024*1024),
|
||||||
|
gc_stats.collections);
|
||||||
|
|
||||||
|
fprintf(stderr, "Max GC time was %0.6f sec, avg. %0.6f sec; peak heap size was %d bytes.\n",
|
||||||
|
max_time, (total_time / gc_stats.collections), gc_stats.high_water);
|
||||||
|
}
|
||||||
|
|
||||||
|
/* vim:set sw=2 expandtab: */
|
||||||
Loading…
Reference in New Issue