nybble
/
rosella
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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:
Jesse D. McDonald 2009-11-08 02:13:02 -06:00
parent 080906fa72
commit 0a2f13b523
10 changed files with 853 additions and 289 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
Makefile
View File

@ -1,14 +1,15 @@
CFLAGS = -std=c99
LDFLAGS = -lrt
ifeq ($(DEBUG),yes)
CFLAGS += -g
PROFILE = no
dummy := $(shell rm -f gc_test *.gcda *.gcno *.o)
dummy := $(shell rm -f rosella *.gcda *.gcno *.o)
else
CFLAGS += -O3 -DNDEBUG -march=nocona
endif
all: gc_test
all: rosella
.PHONY: all clean
ifneq ($(PROFILE),no)
@ -18,13 +19,15 @@ endif
ifneq (,$(wildcard *.gcda))
CFLAGS += -fprofile-use
dummy := $(shell rm -f gc_test *.o)
dummy := $(shell rm -f rosella *.o)
endif
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
builtin.o: builtin.c builtin.h gc.h
interp.o: interp.c interp.h gc.h builtin.h

181
builtin.c Normal file
View File

@ -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: */

46
builtin.h Normal file
View File

@ -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: */

8
doc/bytecode.txt
View File

@ -125,8 +125,8 @@ in:
fN (1NNNNNNN) [frame, N < 120]
-- (11111NNN) [reserved, N < 5]
argv (11111101) [argument list]
ctx (11111110) [dynamic context]
k (11111111) [continuation]
k (11111110) [continuation]
ctx (11111111) [dynamic context]
out:
fN (1NNNNNNN) [0 <= N < 120]
@ -138,8 +138,8 @@ lambda:[
code: byte-string containing sequence of 4-byte instruction words
tail-call: in-ref of lambda 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
context: in-ref of dynamic context to pass to tail-call
]
template:[
@ -149,8 +149,8 @@ template:[
code: linked
tail-call: copied verbatim
arguments: copied verbatim
context: copied verbatim
continuation: copied verbatim
context: copied verbatim
]
Protocol:

80
gc.c
View File

@ -1,3 +1,5 @@
#define _POSIX_C_SOURCE 199309L
#include <assert.h>
#include <inttypes.h>
#include <stdbool.h>
@ -13,7 +15,7 @@ gc_stats_t gc_stats;
/* Helper macros to reduce duplication */
#define VECTOR_BYTES(nelem) (sizeof(vector_t) + (sizeof(value_t) * (nelem)))
#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 */
#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;
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);
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->slots[0] = type_root.value;
for (int i = 1; i < nslots; ++i)
for (int i = 0; i < nslots; ++i)
s->slots[i] = NIL;
unregister_gc_root(&type_root);
@ -275,7 +271,7 @@ static will_t *get_will(value_t v)
abort();
}
intptr_t get_fixnum(value_t v)
fixnum_t get_fixnum(value_t v)
{
if (is_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)
{
if (((uintptr_t)object >= (uintptr_t)gc_ranges[0]) &&
((uintptr_t)object < (uintptr_t)gc_ranges[1]))
if (((value_t)object >= (value_t)gc_ranges[0]) &&
((value_t)object < (value_t)gc_ranges[1]))
return 0;
if (((uintptr_t)object >= (uintptr_t)gc_ranges[1]) &&
((uintptr_t)object < (uintptr_t)gc_ranges[2]))
if (((value_t)object >= (value_t)gc_ranges[1]) &&
((value_t)object < (value_t)gc_ranges[2]))
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_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.max_ns = 0;
gc_weak_box_list = NIL;
gc_will_list = NIL;
@ -383,12 +381,14 @@ static void transfer_object(value_t *value)
switch (obj->tag)
{
case TYPE_TAG_VECTOR:
case TYPE_TAG_STRUCT:
nbytes = VECTOR_BYTES(((const vector_t*)obj)->size);
break;
case TYPE_TAG_BYTESTR:
nbytes = BYTESTR_BYTES(((const byte_string_t*)obj)->size);
break;
case TYPE_TAG_STRUCT:
nbytes = STRUCT_BYTES(((const struct_t*)obj)->nslots);
break;
case TYPE_TAG_WEAK_BOX:
nbytes = sizeof(weak_box_t);
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)
{
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);
}
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)
{
transfer_object(&p->car);
@ -447,10 +456,11 @@ static size_t transfer_children(object_t *obj)
switch (obj->tag)
{
case TYPE_TAG_VECTOR:
case TYPE_TAG_STRUCT:
return transfer_vector((vector_t*)obj);
case TYPE_TAG_BYTESTR:
return BYTESTR_BYTES(((const byte_string_t*)obj)->size);
case TYPE_TAG_STRUCT:
return transfer_struct((struct_t*)obj);
case TYPE_TAG_WEAK_BOX:
return sizeof(weak_box_t);
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)
{
size_t bytes_used = gc_free_ptr - gc_ranges[gc_current_range];
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)
new_limit = gc_max_size;
#if 0
#if 1
else if (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;
#else
if (new_limit > gc_soft_limit)
@ -598,9 +616,11 @@ static void _collect_garbage(size_t min_free)
{
if (gc_enabled)
{
struct timespec start_time;
char *object_ptr;
gc_stats.total_ticks -= clock();
clock_gettime(CLOCK_MONOTONIC, &start_time);
gc_stats.total_freed -= gc_free_space();
++gc_stats.collections;
//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));
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);

37
gc.h
View File

@ -5,6 +5,7 @@
#include <inttypes.h>
#include <stdbool.h>
#include <stdio.h>
#include <time.h>
#ifndef NDEBUG
# define debug(printf_args) ((void)printf printf_args)
@ -13,6 +14,7 @@
#endif
typedef uintptr_t value_t;
typedef intptr_t fixnum_t;
/* NIL: 00000000 00000000 00000000 00000000 */
/* 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_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
{
value_t tag;
@ -75,7 +87,8 @@ typedef struct byte_string
typedef struct structure
{
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];
} struct_t;
@ -101,11 +114,15 @@ typedef struct gc_root
struct gc_root *next;
} gc_root_t;
typedef uint64_t nsec_t;
typedef struct gc_stats
{
int collections;
clock_t total_ticks;
nsec_t total_ns;
uint64_t total_freed;
size_t high_water;
nsec_t max_ns;
} gc_stats_t;
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);
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 slots);
value_t make_struct(value_t type, size_t nslots);
struct_t *get_struct(value_t v);
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. */
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);
}
static inline size_t struct_type(value_t v)
{
return get_struct(v)->slots[0];
}
static inline bool is_weak_box(value_t v)
{
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;
}
static inline value_t make_fixnum(intptr_t n)
static inline value_t make_fixnum(fixnum_t n)
{
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);

239
gc_test.c
View File

@ -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: */

233
interp.c Normal file
View File

@ -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: */

10
interp.h Normal file
View File

@ -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: */

285
rosella.c Normal file
View File

@ -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: */