Permalink
Browse files

continuation support, still buggy

  • Loading branch information...
1 parent c65ecfd commit 73b59b919b4f1d6a88a495089fa763319bf001df @cpylua committed Mar 24, 2012
Showing with 368 additions and 5 deletions.
  1. +131 −0 cont.c
  2. +23 −0 cont.h
  3. +51 −1 eval.c
  4. +28 −2 gc.c
  5. +6 −1 gc.h
  6. +2 −0 lib/core.scm
  7. +4 −0 main.c
  8. +1 −1 makefile
  9. +14 −0 object.h
  10. +15 −0 procdef.c
  11. +1 −0 procdef.h
  12. +6 −0 sform.c
  13. +1 −0 sform.h
  14. +56 −0 stack.c
  15. +3 −0 stack.h
  16. +24 −0 test/cont.scm
  17. +2 −0 write.c
View
131 cont.c
@@ -0,0 +1,131 @@
+#include <stdlib.h>
+#include <stdio.h>
+#include <setjmp.h>
+#include <string.h>
+#include "object.h"
+#include "mem.h"
+#include "cont.h"
+#include "stack.h"
+#include "gc.h"
+#include "log.h"
+
+extern long *g_stack_bottom;
+static volatile object *escape_val;
+
+static void fatal(char *msg) {
+ fprintf(stderr, "[cont] %s\n", msg);
+ exit(-1);
+}
+
+static cont* alloc_cont(void) {
+ cont *c;
+ c = sc_malloc(sizeof(cont));
+ if (c == NULL) {
+ fatal("not enough memory");
+ }
+ return c;
+}
+/*
+static void dump_cont(cont *c) {
+ fprintf(stderr, "stack=%p,stack size=%ld\n",
+ cont_stack(c), cont_stacksize(c));
+ fprintf(stderr, "gc root stack size=%d\n", cont_gcstack(c).size);
+}
+*/
+static void save_stack(cont *c, long *pbos, long *ptos) {
+ long n = pbos - ptos;
+ long *stk;
+ long i;
+
+ stk = sc_malloc(sizeof(long) * n);
+ if (stk == NULL) {
+ fatal("not enough memory");
+ }
+ for (i = 0; i < n; i++) {
+ stk[i] = pbos[-i];
+ }
+ cont_stack(c) = stk;
+ cont_stacksize(c) = n;
+}
+
+static void save_gc_state(cont *c) {
+ object **cap;
+
+ cap = gc_stack_root_deepcopy();
+ if (cap == NULL) {
+ fatal("not enough memory");
+ }
+ cont_capture(c) = cap;
+ if (gc_stack_root_copy(&cont_gcstack(c)) != 0) {
+ fatal("failed to copy gc root stack");
+ }
+}
+
+int is_cont(object *obj) {
+ return obj != NULL && type(obj) == CONT;
+}
+
+/* save_cont returns NULL when control returns from longjmp */
+object* save_cont(void) {
+ cont *c = alloc_cont();
+ int ret;
+ volatile long stack_top;
+
+ if ((ret = setjmp(cont_ctx(c))) == 0) {
+ save_stack(c, g_stack_bottom, (long*)&stack_top);
+ save_gc_state(c);
+
+ object *obj = alloc_object();
+ obj_cont(obj) = c;
+ type(obj) = CONT;
+ return obj;
+ } else {
+ /* continuation return */
+ escape_val = (object*)ret;
+ return NULL;
+ }
+}
+
+/* restore_cont never returns, control is passed to save_cont */
+void internal_restore_cont(cont *c, object *val, int once_more) {
+ volatile long padding[32];
+ long tos;
+ int i, n;
+ long *stk;
+
+ padding[0] = 12;
+ padding[2] = padding[0] + 2;
+
+ /* make sure there's enough room on the stack */
+ if (g_stack_bottom - cont_stacksize(c) < &tos) {
+ internal_restore_cont(c, val, 1);
+ }
+ if (once_more) {
+ internal_restore_cont(c, val, 0);
+ }
+
+ /* restore gc root stack */
+ gc_stack_root_swap(&cont_gcstack(c));
+
+ /* restore stack */
+ n = cont_stacksize(c);
+ stk = cont_stack(c);
+ for (i = 0; i < n; i++) {
+ g_stack_bottom[-i] = stk[i];
+ }
+ longjmp(cont_ctx(c), (int)val);
+}
+
+object* get_escape_val(void) {
+ return (object*)escape_val;
+}
+
+void cont_free(object *obj) {
+ cont *c = obj_cont(obj);
+ sc_free(cont_capture(c));
+ sc_free(cont_gcstack(c).elems);
+ sc_free(cont_stack(c));
+ sc_free(c);
+ obj_cont(obj) = NULL;
+}
+
View
23 cont.h
@@ -0,0 +1,23 @@
+#ifndef _CONT_H_
+#define _CONT_H_
+
+#include "object.h"
+#include "stack.h"
+#include "setjmp.h"
+
+typedef struct cont {
+ jmp_buf ctx;
+ long *stack;
+ long stack_size;
+ struct object **capture;
+ struct stack gc_root_stack;
+} cont;
+
+#define cont_ctx(c) (c->ctx)
+#define cont_stack(c) (c->stack)
+#define cont_stacksize(c) (c->stack_size)
+#define cont_gcstack(c) (c->gc_root_stack)
+#define cont_capture(c) (c->capture)
+
+#endif
+
View
52 eval.c
@@ -15,6 +15,9 @@ static int is_self_evaluate(object *exp) {
is_character(exp) ||
is_string(exp) ||
is_env_frame(exp) ||
+ is_cont(exp) ||
+ is_primitive_proc(exp) ||
+ is_compound_proc(exp) ||
is_eof_object(exp);
}
@@ -621,7 +624,7 @@ static object* eval_env(object *args) {
object* sc_eval(object *exp, object *env) {
- object *val;
+ object *val = NULL;
gc_protect(exp);
gc_protect(env);
@@ -785,6 +788,40 @@ object* sc_eval(object *exp, object *env) {
goto tailcall;
}
+ if (is_callwcc(op)) {
+ object *c;
+ if (!is_empty_list(cdr(args))) {
+ fprintf(stderr, "wrong arity `");
+ sc_write(stderr, exp);
+ fprintf(stderr, "\n");
+ gc_abandon();
+ gc_abandon();
+ gc_abandon();
+ gc_abandon();
+ return NULL;
+ }
+ c = save_cont();
+ if (c != NULL) {
+ /* continuation saved */
+ gc_protect(c);
+ c = cons(c, get_empty_list());
+ c = cons(car(args), c);
+ exp = c;
+ gc_abandon();
+ gc_abandon();
+ gc_abandon();
+ goto tailcall;
+ } else {
+ /* continuation returns */
+ val = get_escape_val();
+ gc_abandon();
+ gc_abandon();
+ gc_abandon();
+ gc_abandon();
+ return val;
+ }
+ }
+
if (is_primitive_proc(op)) {
fn = obj_fv(op);
if (fn == NULL) {
@@ -829,6 +866,19 @@ object* sc_eval(object *exp, object *env) {
gc_abandon();
gc_abandon();
goto tailcall;
+ } else if (is_cont(op)) {
+ if (!is_empty_list(cdr(args))) {
+ fprintf(stderr, "wrong arity `");
+ sc_write(stderr, exp);
+ fprintf(stderr, "\n");
+ gc_abandon();
+ gc_abandon();
+ gc_abandon();
+ gc_abandon();
+ return NULL;
+ }
+ /* never return, stack root is automatically abandoned*/
+ restore_cont(obj_cont(op), car(args));
} else {
fprintf(stderr, "%s `", "object not applicable");
sc_write(stderr, exp);
View
30 gc.c
@@ -8,6 +8,7 @@
#include "log.h"
#include "mem.h"
#include "sform.h"
+#include "cont.h"
static gc_heap heap;
static gc_list free_list, active_list;
@@ -276,6 +277,9 @@ static void gc_free(object *obj) {
case VECTOR:
vector_free(obj);
break;
+ case CONT:
+ cont_free(obj);
+ break;
default:
break;
}
@@ -300,7 +304,7 @@ static void mark_object(object *obj) {
}
mark_active(obj);
- /* env_frame, pairs, vector and compound procedures have nested objects */
+
if (is_pair(obj)) {
object *car_obj, *cdr_obj;
car_obj = car(obj);
@@ -330,6 +334,15 @@ static void mark_object(object *obj) {
mark_object(array[i]);
}
}
+ if (is_cont(obj)) {
+ struct cont *c = obj_cont(obj);
+ object **objs = c->capture;
+ int n = c->gc_root_stack.size;
+ int i = 0;
+ for (; i < n; i++) {
+ mark_object(objs[i]);
+ }
+ }
}
static void mark_stack_root(stack_elem elem) {
@@ -349,6 +362,7 @@ static void mark_sform(void) {
mark_active(get_let_symbol());
mark_active(get_and_symbol());
mark_active(get_or_symbol());
+ mark_active(get_callwcc_symbol());
}
static void mark(void) {
@@ -441,8 +455,20 @@ void gc_stack_root_push(object **obj) {
stack_push(stack_root, elem);
}
-void gc_stack_root_pop() {
+void gc_stack_root_pop(void) {
stack_pop(stack_root);
}
+object** gc_stack_root_deepcopy(void) {
+ return stack_deepcopy(stack_root);
+}
+
+int gc_stack_root_copy(stack *dst) {
+ return stack_copy(stack_root, dst);
+}
+
+int gc_stack_root_swap(stack *src) {
+ return stack_swap(stack_root, src);
+}
+
View
7 gc.h
@@ -2,6 +2,7 @@
#define _GC_H_
#include "object.h"
+#include "stack.h"
typedef struct gc_heap {
struct object *segments;
@@ -27,8 +28,12 @@ void gc(void);
void gc_finalize(void);
void dump_gc_summary(void);
+object** gc_stack_root_deepcopy(void);
+int gc_stack_root_copy(stack *dst);
+int gc_stack_root_swap(stack *src);
+int is_gc_stack_root(stack *s);
void gc_stack_root_push(object **obj);
-void gc_stack_root_pop();
+void gc_stack_root_pop(void);
#define gc_protect(obj) \
gc_stack_root_push(&obj)
#define gc_abandon() \
View
@@ -480,3 +480,5 @@
(define sort merge-sort)
+(define call/cc call-with-current-continuation)
+
View
4 main.c
@@ -6,6 +6,7 @@
#include "gc.h"
double startup_time;
+volatile long *g_stack_bottom;
static void dispose(void) {
dispose_obj();
@@ -57,8 +58,11 @@ static int init(void) {
}
int main(int argc, char **argv) {
+ volatile long stack_bottom;
int ret;
+ g_stack_bottom = &stack_bottom;
+
ret = init();
if (ret != 0) {
fprintf(stderr, "%s\n",
View
@@ -5,7 +5,7 @@ OBJS = eval.o mem.o reader.o fixnum.o charcache.o \
primitive.o procdef.o compound.o eof.o \
port.o ioproc.o gc.o stack.o intcache.o \
mathproc.o strproc.o objstream.o vector.o \
- vecproc.o frame.o
+ vecproc.o frame.o cont.o
CFLAG = -Wall -c
LFLAG = -lm -lrt
Oops, something went wrong.

0 comments on commit 73b59b9

Please sign in to comment.