conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
picrin/lib/proc.c

814 lines
21 KiB
C
Raw Blame History

/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
#include "value.h"
#include "object.h"
#include "state.h"
static struct irep *
assemble(pic_state *pic, pic_value as)
{
pic_value codes, reps, objs;
int argc, varg, frame_size, repc, objc, i;
struct irep **irep, *ir;
pic_value *obj, r, it;
code_t *code;
size_t ai = pic_enter(pic);
codes = pic_list_ref(pic, as, 0);
reps = pic_list_ref(pic, as, 1);
objs = pic_list_ref(pic, as, 2);
argc = pic_int(pic, pic_car(pic, pic_list_ref(pic, as, 3)));
varg = pic_bool(pic, pic_cdr(pic, pic_list_ref(pic, as, 3)));
frame_size = pic_int(pic, pic_list_ref(pic, as, 4));
repc = pic_length(pic, reps);
objc = pic_length(pic, objs);
assert(0 <= argc && argc < 256);
assert(0 <= frame_size && frame_size < 256);
assert(0 <= repc && repc < 256);
assert(0 <= objc && objc < 256);
irep = pic_malloc(pic, sizeof(*irep) * repc);
i = 0;
pic_for_each (r, reps, it) {
irep[i++] = assemble(pic, r);
}
obj = pic_malloc(pic, sizeof(*obj) * objc);
i = 0;
pic_for_each (r, objs, it) {
obj[i++] = r;
}
i = 0;
pic_for_each (r, codes, it) {
if (! pic_pair_p(pic, r))
continue;
if (pic_eq_p(pic, pic_car(pic, r), pic_intern_lit(pic, "COND"))) {
i += 4;
continue;
}
i += pic_length(pic, r);
}
code = pic_malloc(pic, i);
i = 0;
/* TODO: validate operands */
pic_for_each (r, codes, it) {
pic_value op;
if (! pic_pair_p(pic, r))
continue;
op = pic_car(pic, r);
if (pic_eq_p(pic, op, pic_intern_lit(pic, "HALT"))) {
code[i++] = OP_HALT;
}
else if (pic_eq_p(pic, op, pic_intern_lit(pic, "CALL"))) {
code[i++] = OP_CALL;
code[i++] = pic_int(pic, pic_list_ref(pic, r, 1));
}
else if (pic_eq_p(pic, op, pic_intern_lit(pic, "PROC"))) {
code[i++] = OP_PROC;
code[i++] = pic_int(pic, pic_list_ref(pic, r, 1));
code[i++] = pic_int(pic, pic_list_ref(pic, r, 2));
}
else if (pic_eq_p(pic, op, pic_intern_lit(pic, "LOAD"))) {
code[i++] = OP_LOAD;
code[i++] = pic_int(pic, pic_list_ref(pic, r, 1));
code[i++] = pic_int(pic, pic_list_ref(pic, r, 2));
}
else if (pic_eq_p(pic, op, pic_intern_lit(pic, "LREF"))) {
code[i++] = OP_LREF;
code[i++] = pic_int(pic, pic_list_ref(pic, r, 1));
code[i++] = pic_int(pic, pic_list_ref(pic, r, 2));
code[i++] = pic_int(pic, pic_list_ref(pic, r, 3));
}
else if (pic_eq_p(pic, op, pic_intern_lit(pic, "LSET"))) {
code[i++] = OP_LSET;
code[i++] = pic_int(pic, pic_list_ref(pic, r, 1));
code[i++] = pic_int(pic, pic_list_ref(pic, r, 2));
code[i++] = pic_int(pic, pic_list_ref(pic, r, 3));
}
else if (pic_eq_p(pic, op, pic_intern_lit(pic, "GREF"))) {
code[i++] = OP_GREF;
code[i++] = pic_int(pic, pic_list_ref(pic, r, 1));
code[i++] = pic_int(pic, pic_list_ref(pic, r, 2));
}
else if (pic_eq_p(pic, op, pic_intern_lit(pic, "GSET"))) {
code[i++] = OP_GSET;
code[i++] = pic_int(pic, pic_list_ref(pic, r, 1));
code[i++] = pic_int(pic, pic_list_ref(pic, r, 2));
}
else if (pic_eq_p(pic, op, pic_intern_lit(pic, "COND"))) {
pic_value label = pic_list_ref(pic, r, 2);
pic_value x, it2;
int offset = 0;
pic_for_each (x, it, it2) {
if (pic_eq_p(pic, x, label))
break;
if (! pic_pair_p(pic, x))
continue;
if (pic_eq_p(pic, pic_car(pic, x), pic_intern_lit(pic, "COND"))) {
offset += 4;
continue;
}
offset += pic_length(pic, x);
}
code[i++] = OP_COND;
code[i++] = pic_int(pic, pic_list_ref(pic, r, 1));
code[i++] = offset % 256;
code[i++] = offset / 256;
}
else if (pic_eq_p(pic, op, pic_intern_lit(pic, "LOADT"))) {
code[i++] = OP_LOADT;
code[i++] = pic_int(pic, pic_list_ref(pic, r, 1));
}
else if (pic_eq_p(pic, op, pic_intern_lit(pic, "LOADF"))) {
code[i++] = OP_LOADF;
code[i++] = pic_int(pic, pic_list_ref(pic, r, 1));
}
else if (pic_eq_p(pic, op, pic_intern_lit(pic, "LOADN"))) {
code[i++] = OP_LOADN;
code[i++] = pic_int(pic, pic_list_ref(pic, r, 1));
}
else if (pic_eq_p(pic, op, pic_intern_lit(pic, "LOADU"))) {
code[i++] = OP_LOADU;
code[i++] = pic_int(pic, pic_list_ref(pic, r, 1));
}
else if (pic_eq_p(pic, op, pic_intern_lit(pic, "LOADI"))) {
code[i++] = OP_LOADI;
code[i++] = pic_int(pic, pic_list_ref(pic, r, 1));
code[i++] = pic_int(pic, pic_list_ref(pic, r, 2));
}
}
ir = (struct irep *)pic_obj_alloc(pic, PIC_TYPE_IREP);
ir->argc = argc;
ir->flags = (varg ? IREP_VARG : 0);
ir->frame_size = frame_size;
ir->irepc = repc;
ir->objc = objc;
ir->irep = irep;
ir->obj = obj;
ir->code = code;
ir->codec = i;
pic_leave(pic, ai);
pic_protect(pic, obj_value(pic, ir));
return ir;
}
struct frame *
pic_make_frame_unsafe(pic_state *pic, int n)
{
struct frame *fp;
int i;
fp = (struct frame *)pic_obj_alloc_unsafe(pic, PIC_TYPE_FRAME);
fp->regs = n ? pic_malloc(pic, sizeof(pic_value) * n) : NULL;
fp->regc = n;
fp->up = NULL;
for (i = 0; i < n; ++i) {
fp->regs[i] = pic_invalid_value(pic);
}
return fp;
}
pic_value
pic_lambda(pic_state *pic, pic_func_t f, int n, ...)
{
pic_value proc;
va_list ap;
va_start(ap, n);
proc = pic_vlambda(pic, f, n, ap);
va_end(ap);
return proc;
}
pic_value
pic_vlambda(pic_state *pic, pic_func_t f, int n, va_list ap)
{
struct proc *proc;
int i;
assert(n >= 0);
proc = (struct proc *)pic_obj_alloc(pic, PIC_TYPE_PROC_FUNC);
proc->u.func = f;
proc->env = NULL;
if (n != 0) {
proc->env = pic_make_frame_unsafe(pic, n);
}
for (i = 0; i < n; ++i) {
proc->env->regs[i] = va_arg(ap, pic_value);
}
return obj_value(pic, proc);
}
pic_value
pic_make_proc_irep_unsafe(pic_state *pic, struct irep *irep, struct frame *fp)
{
struct proc *proc;
proc = (struct proc *)pic_obj_alloc_unsafe(pic, PIC_TYPE_PROC_IREP);
proc->u.irep = irep;
proc->env = fp;
return obj_value(pic, proc);
}
PIC_NORETURN static void
arg_error(pic_state *pic, int actual, bool varg, int expected)
{
const char *msg;
msg = pic_cstr(pic, pic_strf_value(pic, "wrong number of arguments (%d for %s%d)", actual, (varg ? "at least " : ""), expected), NULL);
pic_error(pic, msg, 0);
}
#define GET_ARGC(pic) (pic->cxt->pc[1])
#define GET_PROC(pic) (pic->cxt->fp->regs[0])
#define GET_CONT(pic) (pic->cxt->fp->regs[1])
#define GET_ARG(pic,n) (pic->cxt->fp->regs[(n)+2])
/**
* char type desc.
* ---- ---- ----
* o pic_value * object
* i int * int
* I int *, bool * int with exactness
* f double * float
* F double *, bool * float with exactness
* c char * char
* z char ** c string
* b unsigned char *, int * bytevector
* u void **, const pic_data_type * user data type
* m pic_value * symbol
* v pic_value * vector
* s pic_value * string
* l pic_value * lambda
* d pic_value * dictionary
* r pic_value * record
*
* + aliasing operator
* | optional operator
* * int *, pic_value ** variable length operator
* ---- ---- ----
*/
int
pic_get_args(pic_state *pic, const char *format, ...)
{
char c;
const char *p = format;
int paramc = 0, optc = 0;
bool proc = 0, rest = 0, opt = 0;
int i, argc = GET_ARGC(pic) - 1; /* one for continuation */
va_list ap;
/* parse format */
if ((c = *p) != '\0') {
if (c == '&') {
proc = 1;
p++;
}
while ((c = *p++) != '\0') {
if (c == '+')
continue;
if (c == '|') {
opt = 1; break;
} else if (c == '*') {
rest = 1; break;
}
paramc++;
}
if (opt) {
while ((c = *p++) != '\0') {
if (c == '+')
continue;
if (c == '*') {
rest = 1; break;
}
optc++;
}
}
if (rest) c = *p++;
assert(opt <= optc); /* at least 1 char after '|'? */
assert(c == '\0'); /* no extra chars? */
}
if (argc < paramc || (paramc + optc < argc && ! rest)) {
arg_error(pic, argc, rest, paramc);
}
va_start(ap, format);
/* dispatch */
if (proc) {
pic_value *proc;
proc = va_arg(ap, pic_value *);
*proc = GET_PROC(pic);
format++; /* skip '&' */
}
for (i = 0; i < argc && i < paramc + optc; ++i) {
c = *format++;
if (c == '|') {
c = *format++;
}
switch (c) {
case 'o': {
pic_value *p;
p = va_arg(ap, pic_value*);
*p = GET_ARG(pic, i);
break;
}
case 'u': {
void **data;
const pic_data_type *type;
pic_value v;
data = va_arg(ap, void **);
type = va_arg(ap, const pic_data_type *);
v = GET_ARG(pic, i);
if (pic_data_p(pic, v, type)) {
*data = pic_data(pic, v);
}
else {
const char *msg;
msg = pic_cstr(pic, pic_strf_value(pic, "pic_get_args: data type \"%s\" required", type->type_name), NULL);
pic_error(pic, msg, 1, v);
}
break;
}
case 'b': {
unsigned char **buf;
int *len;
pic_value v;
buf = va_arg(ap, unsigned char **);
len = va_arg(ap, int *);
v = GET_ARG(pic, i);
if (pic_blob_p(pic, v)) {
unsigned char *tmp = pic_blob(pic, v, len);
if (buf) *buf = tmp;
}
else {
pic_error(pic, "pic_get_args: bytevector required", 1, v);
}
break;
}
#define NUM_CASE(c1, c2, ctype) \
case c1: case c2: { \
ctype *n; \
bool *e, dummy; \
pic_value v; \
\
n = va_arg(ap, ctype *); \
e = (c == c2 ? va_arg(ap, bool *) : &dummy); \
\
v = GET_ARG(pic, i); \
switch (pic_type(pic, v)) { \
case PIC_TYPE_FLOAT: \
*n = pic_float(pic, v); \
*e = false; \
break; \
case PIC_TYPE_INT: \
*n = pic_int(pic, v); \
*e = true; \
break; \
default: \
pic_error(pic, "pic_get_args: float or int required", 1, v); \
} \
break; \
}
NUM_CASE('i', 'I', int)
NUM_CASE('f', 'F', double)
#define VAL_CASE(c, type, ctype, conv) \
case c: { \
ctype *ptr; \
pic_value v; \
\
ptr = va_arg(ap, ctype *); \
v = GET_ARG(pic, i); \
if (pic_## type ##_p(pic, v)) { \
*ptr = conv; \
} \
else { \
pic_error(pic, "pic_get_args: " #type " required", 1, v); \
} \
break; \
}
VAL_CASE('c', char, char, pic_char(pic, v))
VAL_CASE('z', str, const char *, pic_cstr(pic, v, NULL))
#define OBJ_CASE(c, type) VAL_CASE(c, type, pic_value, v)
OBJ_CASE('m', sym)
OBJ_CASE('s', str)
OBJ_CASE('l', proc)
OBJ_CASE('v', vec)
OBJ_CASE('d', dict)
OBJ_CASE('r', rec)
default:
pic_error(pic, "pic_get_args: invalid argument specifier given", 1, pic_char_value(pic, c));
}
if (*format == '+') {
pic_value *p;
format++;
p = va_arg(ap, pic_value *);
*p = GET_ARG(pic, i);
}
}
if (rest) {
int *n;
pic_value **argv;
n = va_arg(ap, int *);
argv = va_arg(ap, pic_value **);
*n = argc - i;
*argv = &GET_ARG(pic, i);
}
va_end(ap);
return argc;
}
pic_value
pic_closure_ref(pic_state *pic, int n)
{
struct frame *fp = pic->cxt->fp->up;
assert(n >= 0);
if (fp == NULL || fp->regc <= n) {
pic_error(pic, "pic_closure_ref: index out of range", 1, pic_int_value(pic, n));
}
return fp->regs[n];
}
void
pic_closure_set(pic_state *pic, int n, pic_value v)
{
struct frame *fp = pic->cxt->fp->up;
assert(n >= 0);
if (fp == NULL || fp->regc <= n) {
pic_error(pic, "pic_closure_ref: index out of range", 1, pic_int_value(pic, n));
}
fp->regs[n] = v;
}
pic_value
pic_call(pic_state *pic, pic_value proc, int n, ...)
{
pic_value r;
va_list ap;
va_start(ap, n);
r = pic_vcall(pic, proc, n, ap);
va_end(ap);
return r;
}
pic_value
pic_callk(pic_state *pic, pic_value proc, int n, ...)
{
va_list ap;
va_start(ap, n);
pic_vcallk(pic, proc, n, ap);
va_end(ap);
return pic_invalid_value(pic);
}
pic_value
pic_vcall(pic_state *pic, pic_value proc, int n, va_list ap)
{
struct context cxt;
CONTEXT_VINITK(pic, &cxt, proc, pic->halt, n, ap);
cxt.reset = 0;
pic_vm(pic, &cxt);
return pic_protect(pic, cxt.fp->regs[1]);
}
pic_value
pic_vcallk(pic_state *pic, pic_value proc, int n, va_list ap)
{
CONTEXT_VINITK(pic, pic->cxt, proc, GET_CONT(pic), n, ap);
return pic_invalid_value(pic);
}
pic_value
pic_apply(pic_state *pic, pic_value proc, int argc, pic_value *argv)
{
struct context cxt;
CONTEXT_INITK(pic, &cxt, proc, pic->halt, argc, argv);
cxt.reset = 0;
pic_vm(pic, &cxt);
return pic_protect(pic, cxt.fp->regs[1]);
}
pic_value
pic_applyk(pic_state *pic, pic_value proc, int argc, pic_value *argv)
{
CONTEXT_INITK(pic, pic->cxt, proc, GET_CONT(pic), argc, argv);
return pic_invalid_value(pic);
}
pic_value
pic_values(pic_state *pic, int n, ...)
{
va_list ap;
pic_value ret;
va_start(ap, n);
ret = pic_vvalues(pic, n, ap);
va_end(ap);
return ret;
}
pic_value
pic_vvalues(pic_state *pic, int n, va_list ap)
{
if (n == 1) {
return va_arg(ap, pic_value);
}
CONTEXT_VINIT(pic, pic->cxt, GET_CONT(pic), n, ap);
return pic_invalid_value(pic);
}
void
pic_vm(pic_state *pic, struct context *cxt)
{
assert(cxt->fp == NULL);
assert(cxt->irep == NULL);
cxt->conts = pic_nil_value(pic);
cxt->prev = pic->cxt;
pic->cxt = cxt;
if (PIC_SETJMP(cxt->jmp) == 0) {
cxt->ai = pic->ai;
}
#define SAVE (pic->ai = cxt->ai)
#define A (cxt->pc[1])
#define B (cxt->pc[2])
#define C (cxt->pc[3])
#define Bx ((C << 8) + B)
#define REG(i) (cxt->sp->regs[i])
#if PIC_DIRECT_THREADED_VM
# define VM_LOOP JUMP;
# define CASE(x) L_##x:
# define NEXT(n) (cxt->pc += n); JUMP;
# define JUMP goto *oplabels[*cxt->pc];
# define VM_LOOP_END
#else
# define VM_LOOP for (;;) { switch (*cxt->pc) {
# define CASE(x) case x:
# define NEXT(n) (cxt->pc += n); break
# define JUMP break
# define VM_LOOP_END } }
#endif
#if PIC_DIRECT_THREADED_VM
static const void *oplabels[] = {
[OP_HALT] = &&L_OP_HALT, [OP_CALL] = &&L_OP_CALL, [OP_PROC] = &&L_OP_PROC,
[OP_LOAD] = &&L_OP_LOAD, [OP_LREF] = &&L_OP_LREF, [OP_LSET] = &&L_OP_LSET,
[OP_GREF] = &&L_OP_GREF, [OP_GSET] = &&L_OP_GSET, [OP_COND] = &&L_OP_COND,
[OP_LOADT] = &&L_OP_LOADT, [OP_LOADF] = &&L_OP_LOADF, [OP_LOADN] = &&L_OP_LOADN,
[OP_LOADU] = &&L_OP_LOADU, [OP_LOADI] = &&L_OP_LOADI
};
#endif
VM_LOOP {
CASE(OP_HALT) {
pic_value c, it;
pic_for_each (c, pic->cxt->conts, it) {
proc_ptr(pic, c)->env->regs[0] = pic_false_value(pic);
}
pic->cxt = pic->cxt->prev;
return;
}
CASE(OP_CALL) {
struct proc *proc;
if (! pic_proc_p(pic, REG(0))) {
pic_error(pic, "invalid application", 1, REG(0));
}
proc = proc_ptr(pic, REG(0));
if (proc->tt == PIC_TYPE_PROC_FUNC) {
pic_value v;
cxt->sp->up = proc->env; /* push static link */
cxt->fp = cxt->sp;
cxt->sp = NULL;
cxt->irep = NULL;
v = proc->u.func(pic);
if (cxt->sp != NULL) { /* tail call */
SAVE;
JUMP;
} else {
cxt->sp = pic_make_frame_unsafe(pic, 3);
cxt->sp->regs[0] = cxt->fp->regs[1]; /* cont. */
cxt->sp->regs[1] = v;
cxt->pc = MKCALL(cxt, 1);
SAVE;
JUMP;
}
} else {
struct irep *irep = proc->u.irep;
if (A != irep->argc) {
if (! ((irep->flags & IREP_VARG) != 0 && A >= irep->argc)) {
arg_error(pic, A, (irep->flags & IREP_VARG), irep->argc);
}
}
if (irep->flags & IREP_VARG) {
REG(irep->argc + 1) = pic_make_list(pic, A - irep->argc, &REG(irep->argc + 1));
SAVE; /* TODO: get rid of this */
}
cxt->sp->up = proc->env; /* push static link */
cxt->fp = cxt->sp;
cxt->sp = pic_make_frame_unsafe(pic, irep->frame_size);
cxt->pc = irep->code;
cxt->irep = irep;
JUMP;
}
}
CASE(OP_LREF) {
struct frame *f;
int depth = B;
for (f = cxt->fp; depth--; f = f->up);
REG(A) = f->regs[C];
NEXT(4);
}
CASE(OP_LSET) {
struct frame *f;
int depth = B;
for (f = cxt->fp; depth--; f = f->up);
f->regs[C] = REG(A);
NEXT(4);
}
CASE(OP_GREF) {
REG(A) = pic_global_ref(pic, cxt->irep->obj[B]);
NEXT(3);
}
CASE(OP_GSET) {
pic_global_set(pic, cxt->irep->obj[B], REG(A));
NEXT(3);
}
CASE(OP_COND) {
if (pic_false_p(pic, REG(A))) {
NEXT(Bx);
} else {
NEXT(4);
}
}
CASE(OP_PROC) {
REG(A) = pic_make_proc_irep_unsafe(pic, cxt->irep->irep[B], cxt->fp);
NEXT(3);
}
CASE(OP_LOAD) {
REG(A) = cxt->irep->obj[B];
NEXT(3);
}
CASE(OP_LOADU) {
REG(A) = pic_undef_value(pic);
NEXT(2);
}
CASE(OP_LOADT) {
REG(A) = pic_true_value(pic);
NEXT(2);
}
CASE(OP_LOADF) {
REG(A) = pic_false_value(pic);
NEXT(2);
}
CASE(OP_LOADN) {
REG(A) = pic_nil_value(pic);
NEXT(2);
}
CASE(OP_LOADI) {
REG(A) = pic_int_value(pic, (signed char) B);
NEXT(3);
}
} VM_LOOP_END
}
static pic_value
pic_proc_make_procedure(pic_state *pic)
{
pic_value as;
struct irep *irep;
struct proc *proc;
pic_get_args(pic, "o", &as);
irep = assemble(pic, as);
proc = (struct proc *)pic_obj_alloc(pic, PIC_TYPE_PROC_IREP);
proc->u.irep = irep;
proc->env = NULL;
return obj_value(pic, proc);
}
static pic_value
pic_proc_proc_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_bool_value(pic, pic_proc_p(pic, v));
}
static pic_value
pic_proc_apply(pic_state *pic)
{
pic_value proc, *args, *arg_list;
int argc, n, i;
pic_get_args(pic, "l*", &proc, &argc, &args);
if (argc == 0) {
pic_error(pic, "apply: wrong number of arguments", 0);
}
n = argc - 1 + pic_length(pic, args[argc - 1]);
arg_list = pic_alloca(pic, sizeof(pic_value) * n);
for (i = 0; i < argc - 1; ++i) {
arg_list[i] = args[i];
}
while (i < n) {
arg_list[i] = pic_list_ref(pic, args[argc - 1], i - argc + 1);
i++;
}
return pic_applyk(pic, proc, n, arg_list);
}
static pic_value
pic_proc_values(pic_state *pic)
{
int argc;
pic_value *argv;
pic_get_args(pic, "*", &argc, &argv);
if (argc == 1) {
return argv[0];
}
CONTEXT_INIT(pic, pic->cxt, GET_CONT(pic), argc, argv);
return pic_invalid_value(pic);
}
static pic_value
receive_call(pic_state *pic)
{
int argc = pic->cxt->pc[1];
pic_value *args = &pic->cxt->fp->regs[1];
/* receive_call is an inhabitant in the continuation side.
You can not use pic_get_args since it implicitly consumes the first argument. */
CONTEXT_INITK(pic, pic->cxt, pic_closure_ref(pic, 0), pic_closure_ref(pic, 1), argc, args);
return pic_invalid_value(pic);
}
static pic_value
pic_proc_call_with_values(pic_state *pic)
{
pic_value producer, consumer;
pic_get_args(pic, "ll", &producer, &consumer);
CONTEXT_INITK(pic, pic->cxt, producer, pic_lambda(pic, receive_call, 2, consumer, GET_CONT(pic)), 0, (pic_value *) NULL);
return pic_invalid_value(pic);
}
void
pic_init_proc(pic_state *pic)
{
pic_defun(pic, "make-procedure", pic_proc_make_procedure);
pic_defun(pic, "procedure?", pic_proc_proc_p);
pic_defun(pic, "apply", pic_proc_apply);
pic_defun(pic, "values", pic_proc_values);
pic_defun(pic, "call-with-values", pic_proc_call_with_values);
}
Reference in New Issue View Git Blame Copy Permalink