1
/*===========================================================================
2
* Filename : continuation.c
3
* About : A Continuation implementation with setjmp/longjmp
5
* Copyright (C) 2005 Kazuki Ohta <mover AT hct.zaq.ne.jp>
6
* Copyright (C) 2005-2006 Jun Inoue <jun.lambda AT gmail.com>
7
* Copyright (C) 2005-2006 YAMAMOTO Kengo <yamaken AT bp.iij4u.or.jp>
8
* Copyright (c) 2007 SigScheme Project <uim AT freedesktop.org>
10
* All rights reserved.
12
* Redistribution and use in source and binary forms, with or without
13
* modification, are permitted provided that the following conditions
16
* 1. Redistributions of source code must retain the above copyright
17
* notice, this list of conditions and the following disclaimer.
18
* 2. Redistributions in binary form must reproduce the above copyright
19
* notice, this list of conditions and the following disclaimer in the
20
* documentation and/or other materials provided with the distribution.
21
* 3. Neither the name of authors nor the names of its contributors
22
* may be used to endorse or promote products derived from this software
23
* without specific prior written permission.
25
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
26
* IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
27
* THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
28
* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
29
* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
30
* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
31
* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
32
* OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
33
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
34
* OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
35
* ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
36
===========================================================================*/
43
#include "sigscheme.h"
44
#include "sigschemeinternal.h"
46
/*=======================================
47
File Local Macro Definitions
48
=======================================*/
49
#define CONTINUATION_FRAME(cont) \
50
((struct continuation_frame *)SCM_CONTINUATION_OPAQUE(cont))
51
#define CONTINUATION_SET_FRAME SCM_CONTINUATION_SET_OPAQUE
53
/*=======================================
54
File Local Type Definitions
55
=======================================*/
56
struct continuation_frame {
58
* - To hint appropriate alignment on stack, a ScmObj is listed first
59
* - GC marking for these ScmObj are implicitly performed by stack scanning
61
volatile ScmObj dyn_ext;
62
volatile ScmObj ret_val;
64
volatile ScmObj trace_stack;
69
/*=======================================
71
=======================================*/
72
SCM_GLOBAL_VARS_BEGIN(static_continuation);
74
static volatile ScmObj l_current_dynamic_extent;
75
static volatile ScmObj l_continuation_stack;
76
static volatile ScmObj l_trace_stack;
78
SCM_GLOBAL_VARS_END(static_continuation);
79
#define l_current_dynamic_extent \
80
SCM_GLOBAL_VAR(static_continuation, l_current_dynamic_extent)
81
#define l_continuation_stack \
82
SCM_GLOBAL_VAR(static_continuation, l_continuation_stack)
83
#define l_trace_stack \
84
SCM_GLOBAL_VAR(static_continuation, l_trace_stack)
85
SCM_DEFINE_STATIC_VARS(static_continuation);
87
/*=======================================
88
File Local Function Declarations
89
=======================================*/
91
static void initialize_dynamic_extent(void);
92
static void finalize_dynamic_extent(void);
93
static void wind_onto_dynamic_extent(ScmObj before, ScmObj after);
94
static void unwind_dynamic_extent(void);
95
static void enter_dynamic_extent(ScmObj dest);
96
static void exit_dynamic_extent(ScmObj dest);
99
static void initialize_continuation_env(void);
100
static void finalize_continuation_env(void);
101
static void continuation_stack_push(ScmObj cont);
102
static ScmObj continuation_stack_pop(void);
103
static ScmObj continuation_stack_unwind(ScmObj dest_cont);
105
/*=======================================
107
=======================================*/
109
scm_init_continuation(void)
111
SCM_GLOBAL_VARS_INIT(static_continuation);
113
initialize_dynamic_extent();
114
initialize_continuation_env();
116
scm_gc_protect_with_init((ScmObj *)&l_trace_stack, SCM_NULL);
120
scm_fin_continuation(void)
122
finalize_continuation_env();
123
finalize_dynamic_extent();
125
SCM_GLOBAL_VARS_FIN(static_continuation);
128
/*===========================================================================
130
===========================================================================*/
131
#define MAKE_DYNEXT_FRAME(before, after) CONS((before), (after))
132
#define DYNEXT_FRAME_BEFORE CAR
133
#define DYNEXT_FRAME_AFTER CDR
136
initialize_dynamic_extent(void)
138
scm_gc_protect_with_init((ScmObj *)&l_current_dynamic_extent, SCM_NULL);
142
finalize_dynamic_extent(void)
147
wind_onto_dynamic_extent(ScmObj before, ScmObj after)
151
frame = MAKE_DYNEXT_FRAME(before, after);
152
l_current_dynamic_extent = CONS(frame, l_current_dynamic_extent);
156
unwind_dynamic_extent(void)
158
if (NULLP(l_current_dynamic_extent))
159
PLAIN_ERR("corrupted dynamic extent");
161
l_current_dynamic_extent = CDR(l_current_dynamic_extent);
164
/* enter a dynamic extent of another continuation (dest) */
166
enter_dynamic_extent(ScmObj dest)
168
ScmObj frame, unwound, retpath;
169
DECLARE_INTERNAL_FUNCTION("enter_dynamic_extent");
173
while (!NULLP(unwound) && !EQ(unwound, l_current_dynamic_extent)) {
174
frame = POP(unwound);
175
retpath = CONS(frame, retpath);
178
FOR_EACH (frame, retpath)
179
scm_call(DYNEXT_FRAME_BEFORE(frame), SCM_NULL);
182
/* exit to a dynamic extent of another continuation (dest) */
184
exit_dynamic_extent(ScmObj dest)
187
DECLARE_INTERNAL_FUNCTION("exit_dynamic_extent");
189
while (!NULLP(l_current_dynamic_extent)
190
&& !EQ(l_current_dynamic_extent, dest))
192
frame = POP(l_current_dynamic_extent);
193
scm_call(DYNEXT_FRAME_AFTER(frame), SCM_NULL);
198
scm_dynamic_wind(ScmObj before, ScmObj thunk, ScmObj after)
202
scm_call(before, SCM_NULL);
204
wind_onto_dynamic_extent(before, after);
205
ret = scm_call(thunk, SCM_NULL);
206
unwind_dynamic_extent();
208
scm_call(after, SCM_NULL);
213
/*===========================================================================
215
===========================================================================*/
217
initialize_continuation_env(void)
219
scm_gc_protect_with_init((ScmObj *)&l_continuation_stack, SCM_NULL);
223
finalize_continuation_env(void)
228
continuation_stack_push(ScmObj cont)
230
l_continuation_stack = CONS(cont, l_continuation_stack);
234
continuation_stack_pop(void)
236
DECLARE_INTERNAL_FUNCTION("continuation_stack_pop");
238
return NULLP(l_continuation_stack) ? SCM_FALSE : POP(l_continuation_stack);
241
/* expire all descendant continuations and dest_cont */
243
continuation_stack_unwind(ScmObj dest_cont)
248
cont = continuation_stack_pop();
251
CONTINUATION_SET_FRAME(cont, INVALID_CONTINUATION_OPAQUE);
252
} while (!EQ(dest_cont, cont));
258
scm_destruct_continuation(ScmObj cont)
260
/* no object to be free(3) in this implementation */
264
scm_call_with_current_continuation(ScmObj proc, ScmEvalState *eval_state)
266
volatile ScmObj cont, ret;
267
struct continuation_frame cont_frame;
269
cont_frame.dyn_ext = l_current_dynamic_extent;
270
cont_frame.ret_val = SCM_UNDEF;
271
#if SCM_USE_BACKTRACE
272
cont_frame.trace_stack = l_trace_stack;
274
cont = MAKE_CONTINUATION();
275
CONTINUATION_SET_FRAME(cont, &cont_frame);
276
#if SCM_NESTED_CONTINUATION_ONLY
277
continuation_stack_push(cont);
280
if (setjmp(cont_frame.c_env)) {
281
/* returned back to the original continuation */
282
/* Don't refer cont because it may already be invalidated by
283
* continuation_stack_unwind(). */
284
#if SCM_USE_BACKTRACE
285
l_trace_stack = cont_frame.trace_stack;
288
enter_dynamic_extent(cont_frame.dyn_ext);
290
eval_state->ret_type = SCM_VALTYPE_AS_IS;
291
return cont_frame.ret_val;
293
#if SCM_NESTED_CONTINUATION_ONLY
294
/* Call proc with current continutation as (proc cont): This call must
295
* not be scm_values_applier, to preserve current stack until longjmp()
296
* is called. And so this implementation is not properly recursive. */
297
eval_state->ret_type = SCM_VALTYPE_AS_IS;
298
ret = scm_call(proc, LIST_1(cont));
300
/* the continuation expires when this function returned */
301
continuation_stack_unwind(cont);
303
/* ONLY FOR TESTING: This call is properly recursible, but all
304
* continuations are broken and cannot be called, if the continuation
305
* is implemented by longjmp(). */
306
ret = LIST_3(scm_values_applier, proc, cont);
314
scm_call_continuation(ScmObj cont, ScmObj ret)
316
struct continuation_frame *frame;
317
#if SCM_NESTED_CONTINUATION_ONLY
320
DECLARE_INTERNAL_FUNCTION("scm_call_continuation");
322
frame = CONTINUATION_FRAME(cont);
324
if (frame != INVALID_CONTINUATION_OPAQUE
325
#if SCM_NESTED_CONTINUATION_ONLY
326
&& (dst = continuation_stack_unwind(cont), CONTINUATIONP(dst))
330
if (VALUEPACKETP(ret))
331
ERR_OBJ("continuations take exactly one value but got", ret);
333
/* Don't refer cont because it may already be invalidated by
334
* continuation_stack_unwind(). */
335
exit_dynamic_extent(frame->dyn_ext);
337
frame->ret_val = ret;
338
longjmp(frame->c_env, scm_true);
341
ERR("expired continuation");
345
/*===========================================================================
347
===========================================================================*/
348
#if SCM_USE_BACKTRACE
350
scm_push_trace_frame(ScmObj obj, ScmObj env)
354
frame = MAKE_TRACE_FRAME(obj, env);
355
l_trace_stack = CONS(frame, l_trace_stack);
359
scm_pop_trace_frame(void)
361
SCM_ASSERT(CONSP(l_trace_stack));
363
l_trace_stack = CDR(l_trace_stack);
365
#endif /* SCM_USE_BACKTRACE */
368
scm_trace_stack(void)
370
return l_trace_stack;
added
removed
sigscheme/src/continuation.c
