Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

continuation support, still buggy

  • Loading branch information...
commit 73b59b919b4f1d6a88a495089fa763319bf001df 1 parent c65ecfd
@cpylua authored
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
2  lib/core.scm
@@ -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
2  makefile
@@ -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
View
14 object.h
@@ -26,6 +26,7 @@ typedef enum {
EOF_OBJECT,
VECTOR,
ENV_FRAME,
+ CONT,
} object_type;
struct object;
@@ -41,6 +42,8 @@ struct rbnode;
typedef struct rbnode *position;
typedef struct rbnode *rbtree;
+struct cont;
+
typedef struct object {
gc_head gc;
object_type type;
@@ -91,6 +94,9 @@ typedef struct object {
struct {
rbtree tree;
} env_frame;
+ struct {
+ struct cont *c;
+ } continuation;
} data;
} object;
@@ -117,6 +123,7 @@ typedef struct object {
#define gc_mark(p) ((p)->gc.mark)
#define gc_chain(p) ((p)->gc.chain)
#define obj_rbtv(p) (p->data.env_frame.tree)
+#define obj_cont(p) (p->data.continuation.c)
#define SIZEOF_OBJECT sizeof(object)
@@ -225,5 +232,12 @@ object* env_frame_find(object *frame, object *var);
void env_frame_walk(object *frame, env_frame_walk_fn walker);
void env_frame_free(object *obj);
+int is_cont(object *obj);
+object *save_cont(void);
+void internal_restore_cont(struct cont *c, object *val, int once_more);
+void cont_free(object *obj);
+object* get_escape_val(void);
+#define restore_cont(c, v) internal_restore_cont(c, v, 1);
+
#endif
View
15 procdef.c
@@ -1253,6 +1253,20 @@ static int random_proc(object *params, object **result) {
return 0;
}
+static int callwcc_proc(object *params, object **result) {
+ /* handled specially in sc_eval.
+ *
+ * this function exists so that apply can be treated
+ * as normal function in Scheme code.
+ */
+ return SC_E_INV_STAT;
+}
+
+int is_callwcc(object *exp) {
+ return is_primitive_proc(exp) &&
+ obj_fv(exp) == callwcc_proc;
+}
+
#define DEFINE_LIST_PROC(name) \
define_proc(#name, name ## _proc)
@@ -1345,6 +1359,7 @@ int init_primitive(object *env) {
define_proc("eval", eval_proc);
define_proc("apply", apply_proc);
+ define_proc("call-with-current-continuation", callwcc_proc);
define_proc("gc", gc_proc);
define_proc("gc-summary", gc_summary_proc);
View
1  procdef.h
@@ -45,6 +45,7 @@ int init_primitive(object *env);
char* error_str(int err);
int is_apply(object *obj);
int is_eval(object *obj);
+int is_callwcc(object *exp);
int env_define_proc(char *sym, prim_proc fn, object *env);
double number_to_double(object *obj);
View
6 sform.c
@@ -14,6 +14,7 @@ static object *g_else_symbol;
static object *g_let_symbol;
static object *g_and_symbol;
static object *g_or_symbol;
+static object *g_callwcc_symbol;
#define DEFINE_SYMBOL(var, sym) \
{ \
@@ -38,6 +39,7 @@ int sform_init(void) {
DEFINE_SYMBOL(g_let_symbol, "let");
DEFINE_SYMBOL(g_and_symbol, "and");
DEFINE_SYMBOL(g_or_symbol, "or");
+ DEFINE_SYMBOL(g_callwcc_symbol, "call-with-current-continuation");
return 0;
}
@@ -90,3 +92,7 @@ object* get_or_symbol(void) {
return g_or_symbol;
}
+object* get_callwcc_symbol(void) {
+ return g_callwcc_symbol;
+}
+
View
1  sform.h
@@ -17,6 +17,7 @@ object* get_else_symbol(void);
object* get_let_symbol(void);
object* get_and_symbol(void);
object* get_or_symbol(void);
+object* get_callwcc_symbol(void);
#endif
View
56 stack.c
@@ -98,3 +98,59 @@ void stack_for_each(stack *s, visitor_fn fn) {
}
}
+object** stack_deepcopy(stack *s) {
+ stack_elem *p = s->elems;
+ stack_elem *q = p + s->size;
+ object **buf, **base;
+
+ if (s == NULL) {
+ return NULL;
+ }
+
+ buf = sc_malloc(sizeof(object*) * s->size);
+ if (buf == NULL) {
+ return NULL;
+ }
+ base = buf;
+ for (; p != q; p++, buf++) {
+ *buf = **p;
+ }
+ return base;
+}
+
+int stack_swap(stack *this, stack *src) {
+ stack_elem *buf;
+
+ if (this == NULL || src == NULL) {
+ return -1;
+ }
+
+ buf = sc_malloc(src->capacity * sizeof(stack_elem));
+ if (buf == NULL) {
+ return -1;
+ }
+ memcpy(buf, src->elems, sizeof(stack_elem) * src->size);
+ sc_free(this->elems);
+ this->elems = buf;
+ this->capacity = src->capacity;
+ this->size = src->size;
+ return 0;
+}
+
+int stack_copy(stack *this, stack *dst) {
+ stack_elem *buf;
+
+ if (this == NULL || dst == NULL) {
+ return -1;
+ }
+
+ buf = sc_malloc(this->size * sizeof(stack_elem));
+ if (buf == NULL) {
+ return -1;
+ }
+ memcpy(buf, this->elems, this->size * sizeof(stack_elem));
+ dst->elems = buf;
+ dst->capacity = dst->size = this->size;
+ return 0;
+}
+
View
3  stack.h
@@ -18,6 +18,9 @@ void stack_dispose(stack *s);
void stack_push(stack *s, stack_elem obj);
void stack_pop(stack *s);
void stack_for_each(stack *s, visitor_fn fn);
+object **stack_deepcopy(stack *s);
+int stack_copy(stack *this, stack *dst);
+int stack_swap(stack *this, stack *src);
#endif
View
24 test/cont.scm
@@ -0,0 +1,24 @@
+(display
+ (call-with-current-continuation
+ (lambda (exit)
+ (for-each (lambda (x)
+ (if (negative? x)
+ (exit x)))
+ '(54 0 37 -3 245 19))
+ #t)))
+(newline)
+
+(display
+ (+ 1 (call/cc
+ (lambda (k)
+ (+ 2 (k 3))))))
+(newline)
+
+(define r #f)
+(+ 1 (call/cc
+ (lambda (k)
+ (set! r k)
+ (+ 2 (k 3)))))
+
+
+
View
2  write.c
@@ -158,6 +158,8 @@ int sc_write(FILE *out, object *val) {
fprintf(out, "#<output-port@%p>", val);
} else if (is_env_frame(val)) {
fprintf(out, "#<environment-frame@%p>", val);
+ } else if (is_cont(val)) {
+ fprintf(out, "#<continuation@%p>", val);
} else {
fprintf(stderr,
"unknown type, cannot print\n");
Please sign in to comment.
Something went wrong with that request. Please try again.