[uim-commit] r1745 - branches/r5rs/sigscheme
yamaken at freedesktop.org
yamaken at freedesktop.org
Sun Oct 2 13:24:01 PDT 2005
Author: yamaken
Date: 2005-10-02 13:23:59 -0700 (Sun, 02 Oct 2005)
New Revision: 1745
Modified:
branches/r5rs/sigscheme/datas.c
branches/r5rs/sigscheme/eval.c
branches/r5rs/sigscheme/operations.c
branches/r5rs/sigscheme/sigscheme.c
branches/r5rs/sigscheme/sigschemeinternal.h
branches/r5rs/sigscheme/sigschemetype.h
Log:
* This commit encapsulates continuation implementation into datas.c
and optimizes
This changes conflict with recent SRFI-34 codes. To reorganize with
it, I commit this first. Sorry for inconvenience.
* sigscheme/sigschemetype.h
- Remove setjmp.h
- (struct _ScmContInfo, ScmContInfo): Removed
- (struct ScmObjInternal_): Change member definition of struct
ScmContinuation
- (SCM_CONTINUATION_CONTINFO, SCM_CONTINUATION_JMPENV,
SCM_CONTINUATION_SET_CONTINFO): Removed
- (SCM_CONTINUATION_OPAQUE0, SCM_CONTINUATION_SET_OPAQUE0,
SCM_CONTINUATION_OPAQUE1, SCM_CONTINUATION_SET_OPAQUE1): New macro
* sigscheme/sigschemeinternal.h
- (scm_continuation_thrown_obj): Removed
- (Scm_CallWithCurrentContinuation, Scm_CallContinuation): New
function decl
* sigscheme/sigscheme.c
- (SigScm_Initialize_internal): Move continuation environment
initialization into SigScm_InitStorage()
* sigscheme/datas.c
- (SCM_NESTED_CONTINUATION_ONLY): New macro
- (continuation_thrown_obj, continuation_stack): New static variable
- (initialize_continuation_env, finalize_continuation_env,
continuation_stack_push, continuation_stack_pop,
continuation_stack_unwind): New static function
- (SigScm_InitStorage, SigScm_FinalizeStorage): Add continuation
environment handling
- (sweep_obj):
* Remove free(3) for continuation
* Reorder object types based on their probable appearance rate
- (Scm_NewContinuation): Follow the definition change of
continuation object
- (CONTINUATION_JMPENV, CONTINUATION_SET_JMPENV, CONTINUATION_UPPER,
CONTINUATION_SET_UPPER, INVALID_CONTINUATION): New macro
- (Scm_CallWithCurrentContinuation, Scm_CallContinuation): New
function
* sigscheme/eval.c
- Remove setjmp.h
- (scm_continuation_thrown_obj): Removed
- (call): Replace continuation handling with Scm_CallContinuation()
* sigscheme/operations.c
- (ScmOp_call_with_current_continuation): Replace continuation
handling with Scm_CallWithCurrentContinuation()
Modified: branches/r5rs/sigscheme/datas.c
===================================================================
--- branches/r5rs/sigscheme/datas.c 2005-10-02 19:40:45 UTC (rev 1744)
+++ branches/r5rs/sigscheme/datas.c 2005-10-02 20:23:59 UTC (rev 1745)
@@ -107,6 +107,12 @@
/*=======================================
File Local Macro Declarations
=======================================*/
+/* specifies whether the storage abstraction layer can only handle nested
+ * (stacked) continuation or R5RS-conformant full implementation. But current
+ * implementation only supports '1'.
+ */
+#define SCM_NESTED_CONTINUATION_ONLY 1
+
#define NAMEHASH_SIZE 1024
#define SCM_NEW_OBJ_INTERNAL(VALNAME) \
@@ -155,6 +161,10 @@
static jmp_buf save_regs_buf;
ScmObj *scm_stack_start_pointer = NULL;
+/* temporary store for a object returned from a continuation */
+static ScmObj continuation_thrown_obj = NULL;
+static ScmObj continuation_stack = NULL;
+
static ScmObj *symbol_hash = NULL;
static gc_protected_var *protected_var_list = NULL;
@@ -194,6 +204,13 @@
static void sweep_obj(ScmObj obj);
static void gc_sweep(void);
+/* continuation */
+static void initialize_continuation_env(void);
+static void finalize_continuation_env(void);
+static void continuation_stack_push(ScmObj cont);
+static ScmObj continuation_stack_pop(void);
+static ScmObj continuation_stack_unwind(ScmObj dest_cont);
+
static void initialize_symbol_hash(void);
static void finalize_symbol_hash(void);
static int symbol_name_hash(const char *name);
@@ -231,11 +248,14 @@
{
initialize_special_constants();
allocate_heap(&scm_heaps, scm_heap_num, SCM_HEAP_SIZE, &scm_freelist);
+
+ initialize_continuation_env();
initialize_symbol_hash();
}
void SigScm_FinalizeStorage(void)
{
+ finalize_continuation_env();
finalize_heap();
finalize_symbol_hash();
finalize_protected_var();
@@ -531,10 +551,7 @@
switch (SCM_TYPE(obj)) {
case ScmInt:
case ScmCons:
- case ScmFunc:
case ScmClosure:
- case ScmFreeCell:
- case ScmEtc:
break;
case ScmChar:
@@ -574,12 +591,11 @@
free(SCM_PORT_PORTINFO(obj));
break;
+ /* rarely swept objects */
case ScmContinuation:
- /* free continuation info */
- if (SCM_CONTINUATION_CONTINFO(obj))
- free(SCM_CONTINUATION_CONTINFO(obj));
- break;
-
+ case ScmFunc:
+ case ScmEtc:
+ case ScmFreeCell:
default:
break;
}
@@ -802,13 +818,12 @@
ScmObj Scm_NewContinuation(void)
{
ScmObj obj = SCM_FALSE;
- ScmContInfo *cinfo = NULL;
SCM_NEW_OBJ_INTERNAL(obj);
SCM_ENTYPE_CONTINUATION(obj);
- cinfo = (ScmContInfo *)malloc(sizeof(ScmContInfo));
- SCM_CONTINUATION_SET_CONTINFO(obj, cinfo);
+ SCM_CONTINUATION_SET_OPAQUE0(obj, NULL);
+ SCM_CONTINUATION_SET_OPAQUE1(obj, NULL);
return obj;
}
@@ -851,6 +866,123 @@
#endif /* SCM_USE_NONSTD_FEATURES */
/*============================================================================
+ Continuation
+============================================================================*/
+#define CONTINUATION_JMPENV SCM_CONTINUATION_OPAQUE0
+#define CONTINUATION_SET_JMPENV SCM_CONTINUATION_SET_OPAQUE0
+#define CONTINUATION_UPPER SCM_CONTINUATION_OPAQUE1
+#define CONTINUATION_SET_UPPER SCM_CONTINUATION_SET_OPAQUE1
+
+#define INVALID_CONTINUATION NULL
+
+static void initialize_continuation_env(void)
+{
+ continuation_thrown_obj = SCM_FALSE;
+ continuation_stack = SCM_NULL;
+ SigScm_GC_Protect(&continuation_thrown_obj);
+ SigScm_GC_Protect(&continuation_stack);
+}
+
+static void finalize_continuation_env(void)
+{
+ continuation_thrown_obj = NULL;
+ continuation_stack = NULL;
+}
+
+static void continuation_stack_push(ScmObj cont)
+{
+ CONTINUATION_SET_UPPER(cont, continuation_stack);
+ continuation_stack = cont;
+}
+
+static ScmObj continuation_stack_pop(void)
+{
+ ScmObj recentmost;
+
+ recentmost = continuation_stack;
+ continuation_stack = CONTINUATION_UPPER(continuation_stack);
+
+ return recentmost;
+}
+
+/* expire all descendant continuations and dest_cont */
+static ScmObj continuation_stack_unwind(ScmObj dest_cont)
+{
+ ScmObj cont;
+
+ do {
+ if (NULLP(continuation_stack))
+ return INVALID_CONTINUATION;
+ cont = continuation_stack_pop();
+ CONTINUATION_SET_JMPENV(cont, INVALID_CONTINUATION);
+ } while (!EQ(dest_cont, cont));
+
+ return dest_cont;
+}
+
+ScmObj Scm_CallWithCurrentContinuation(ScmObj proc, ScmEvalState *eval_state)
+{
+ jmp_buf env;
+ ScmObj cont = SCM_FALSE;
+ ScmObj ret = SCM_FALSE;
+
+ cont = Scm_NewContinuation();
+ CONTINUATION_SET_JMPENV(cont, &env);
+#if SCM_NESTED_CONTINUATION_ONLY
+ continuation_stack_push(cont);
+#endif
+
+ if (setjmp(env)) {
+ /* returned from longjmp */
+ ret = continuation_thrown_obj;
+ continuation_thrown_obj = SCM_FALSE; /* make ret sweepable */
+
+ eval_state->ret_type = SCM_RETTYPE_AS_IS;
+ return ret;
+ } else {
+#if SCM_NESTED_CONTINUATION_ONLY
+ /* call proc with current continutation as (proc cont): This call must
+ * not be Scm_tailcall(), to preserve current stack until longjmp()
+ * called.
+ */
+ ret = Scm_call(proc, LIST_1(cont));
+#else
+ /* ONLY FOR TESTING: This call is properly recursible, but all
+ * continuations are broken and cannot be called, if the continuation
+ * is implemented by longjmp().
+ */
+ ret = Scm_tailcall(proc, LIST_1(cont), eval_state);
+#endif
+
+#if SCM_NESTED_CONTINUATION_ONLY
+ /* the continuation expires when this function returned */
+ continuation_stack_unwind(cont);
+#endif
+ return ret;
+ }
+}
+
+void Scm_CallContinuation(ScmObj cont, ScmObj ret)
+{
+ jmp_buf *env;
+
+ env = CONTINUATION_JMPENV(cont);
+
+ if (env != INVALID_CONTINUATION
+#if SCM_NESTED_CONTINUATION_ONLY
+ && continuation_stack_unwind(cont) != INVALID_CONTINUATION
+#endif
+ )
+ {
+ continuation_thrown_obj = ret;
+ longjmp(*env, 1);
+ /* NOTREACHED */
+ } else {
+ ERR("Scm_CallContinuation: called expired continuation");
+ }
+}
+
+/*============================================================================
Symbol table
============================================================================*/
/*
Modified: branches/r5rs/sigscheme/eval.c
===================================================================
--- branches/r5rs/sigscheme/eval.c 2005-10-02 19:40:45 UTC (rev 1744)
+++ branches/r5rs/sigscheme/eval.c 2005-10-02 20:23:59 UTC (rev 1745)
@@ -47,7 +47,6 @@
/*=======================================
System Include
=======================================*/
-#include <setjmp.h>
/*=======================================
Local Include
@@ -73,8 +72,6 @@
/*=======================================
Variable Declarations
=======================================*/
-ScmObj scm_continuation_thrown_obj = NULL; /* for storing continuation return object */
-
struct trace_frame *scm_trace_root = NULL;
/*=======================================
@@ -370,9 +367,8 @@
case ScmContinuation:
if (NO_MORE_ARG(args))
SigScm_Error("Continuation invocation lacks an argument.");
- scm_continuation_thrown_obj
- = suppress_eval ? CAR(args) : EVAL(CAR(args), env);
- longjmp(SCM_CONTINUATION_JMPENV(proc), 1);
+ Scm_CallContinuation(proc,
+ suppress_eval ? CAR(args) : EVAL(CAR(args), env));
/* NOTREACHED */
default:
ERR_OBJ("bad operator", proc);
Modified: branches/r5rs/sigscheme/operations.c
===================================================================
--- branches/r5rs/sigscheme/operations.c 2005-10-02 19:40:45 UTC (rev 1744)
+++ branches/r5rs/sigscheme/operations.c 2005-10-02 20:23:59 UTC (rev 1745)
@@ -1786,34 +1786,11 @@
ScmObj ScmOp_call_with_current_continuation(ScmObj proc, ScmEvalState *eval_state)
{
- ScmObj cont = SCM_FALSE;
- ScmObj ret = SCM_FALSE;
DECLARE_FUNCTION("call-with-current-continuation", ProcedureFixedTailRec1);
ASSERT_PROCEDUREP(proc);
- cont = Scm_NewContinuation();
-
- if (setjmp(SCM_CONTINUATION_JMPENV(cont))) {
- /* returned from longjmp */
- eval_state->ret_type = SCM_RETTYPE_AS_IS;
- ret = scm_continuation_thrown_obj;
- scm_continuation_thrown_obj = SCM_FALSE; /* make ret sweepable */
- return ret;
- } else {
-#if 1
- /* call proc with current continutation as (proc cont): This call must
- * not be Scm_tailcall(), to preserve current stack until longjmp()
- * called.
- */
- return Scm_call(proc, LIST_1(cont));
-#else
- /* ONLY FOR TESTING: This call is properly recursible, but all
- * continuations are broken and cannot be called.
- */
- return Scm_tailcall(proc, LIST_1(cont), eval_state);
-#endif
- }
+ return Scm_CallWithCurrentContinuation(proc, eval_state);
}
ScmObj ScmOp_values(ScmObj args)
Modified: branches/r5rs/sigscheme/sigscheme.c
===================================================================
--- branches/r5rs/sigscheme/sigscheme.c 2005-10-02 19:40:45 UTC (rev 1744)
+++ branches/r5rs/sigscheme/sigscheme.c 2005-10-02 20:23:59 UTC (rev 1745)
@@ -93,8 +93,6 @@
Storage Initialization
=======================================================================*/
SigScm_InitStorage();
- scm_continuation_thrown_obj = SCM_FALSE;
- SigScm_GC_Protect(&scm_continuation_thrown_obj);
/*=======================================================================
Interned Variable Initialization
=======================================================================*/
Modified: branches/r5rs/sigscheme/sigschemeinternal.h
===================================================================
--- branches/r5rs/sigscheme/sigschemeinternal.h 2005-10-02 19:40:45 UTC (rev 1744)
+++ branches/r5rs/sigscheme/sigschemeinternal.h 2005-10-02 20:23:59 UTC (rev 1745)
@@ -64,7 +64,6 @@
#endif
/* eval.c */
-extern ScmObj scm_continuation_thrown_obj;
extern struct trace_frame *scm_trace_root;
/* error.c*/
@@ -348,6 +347,8 @@
/* datas.c */
void SigScm_InitStorage(void);
void SigScm_FinalizeStorage(void);
+ScmObj Scm_CallWithCurrentContinuation(ScmObj proc, ScmEvalState *eval_state);
+void Scm_CallContinuation(ScmObj cont, ScmObj ret);
/* eval.c */
/* environment related functions */
Modified: branches/r5rs/sigscheme/sigschemetype.h
===================================================================
--- branches/r5rs/sigscheme/sigschemetype.h 2005-10-02 19:40:45 UTC (rev 1744)
+++ branches/r5rs/sigscheme/sigschemetype.h 2005-10-02 20:23:59 UTC (rev 1745)
@@ -38,7 +38,6 @@
System Include
=======================================*/
#include <stdio.h>
-#include <setjmp.h>
/*=======================================
Local Include
@@ -131,11 +130,6 @@
int ungottenchar;
};
-typedef struct _ScmContInfo ScmContInfo;
-struct _ScmContInfo {
- jmp_buf jmp_env;
-};
-
/*
* Function types:
*
@@ -254,7 +248,8 @@
} port;
struct ScmContinuation {
- ScmContInfo *cont_info;
+ void *opaque0;
+ void *opaque1;
} continuation;
#if !SCM_USE_VALUECONS
@@ -385,9 +380,10 @@
#define SCM_CONTINUATIONP(a) (SCM_TYPE(a) == ScmContinuation)
#define SCM_ENTYPE_CONTINUATION(a) (SCM_ENTYPE((a), ScmContinuation))
-#define SCM_CONTINUATION_CONTINFO(a) (SCM_AS_CONTINUATION(a)->obj.continuation.cont_info)
-#define SCM_CONTINUATION_JMPENV(a) (SCM_AS_CONTINUATION(a)->obj.continuation.cont_info->jmp_env)
-#define SCM_CONTINUATION_SET_CONTINFO(a, cinfo) (SCM_CONTINUATION_CONTINFO(a) = (cinfo))
+#define SCM_CONTINUATION_OPAQUE0(a) (SCM_AS_CONTINUATION(a)->obj.continuation.opaque0)
+#define SCM_CONTINUATION_SET_OPAQUE0(a, val) (SCM_CONTINUATION_OPAQUE0(a) = (val))
+#define SCM_CONTINUATION_OPAQUE1(a) (SCM_AS_CONTINUATION(a)->obj.continuation.opaque1)
+#define SCM_CONTINUATION_SET_OPAQUE1(a, val) (SCM_CONTINUATION_OPAQUE1(a) = (val))
#if SCM_USE_VALUECONS
/* to modify a VALUECONS, rewrite its type to cons by SCM_ENTYPE_CONS(vcons) */
More information about the uim-commit
mailing list