1 /*===========================================================================
2 * Filename : continuation.c
3 * About : A Continuation implementation with setjmp/longjmp
4 *
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-2008 SigScheme Project <uim-en AT googlegroups.com>
9 *
10 * All rights reserved.
11 *
12 * Redistribution and use in source and binary forms, with or without
13 * modification, are permitted provided that the following conditions
14 * are met:
15 *
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.
24 *
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 ===========================================================================*/
37
38 #include <config.h>
39
40 #include <stdlib.h>
41 #include <setjmp.h>
42
43 #include "sigscheme.h"
44 #include "sigschemeinternal.h"
45
46 /*=======================================
47 File Local Macro Definitions
48 =======================================*/
49 #if HAVE_SIGSETJMP
50 #define JMP_BUF sigjmp_buf
51 #define SETJMP(env) sigsetjmp((env), 1)
52 #define LONGJMP(env, val) siglongjmp((env), (val))
53 #else
54 #define JMP_BUF jmp_buf
55 #define SETJMP(env) setjmp(env)
56 #define LONGJMP(env, val) longjmp((env), (val))
57 #endif
58
59 #define CONTINUATION_FRAME(cont) \
60 ((struct scm_continuation_frame *)SCM_CONTINUATION_OPAQUE(cont))
61 #define CONTINUATION_SET_FRAME SCM_CONTINUATION_SET_OPAQUE
62
63 /*=======================================
64 File Local Type Definitions
65 =======================================*/
66 struct scm_continuation_frame {
67 /*
68 * - To hint appropriate alignment on stack, a ScmObj is listed first
69 * - GC marking for these ScmObj are implicitly performed by stack scanning
70 */
71 volatile ScmObj dyn_ext;
72 volatile ScmObj ret_val;
73 #if SCM_USE_BACKTRACE
74 volatile ScmObj trace_stack;
75 #endif
76 JMP_BUF c_env;
77 };
78
79 /*=======================================
80 Variable Definitions
81 =======================================*/
82 SCM_GLOBAL_VARS_BEGIN(static_continuation);
83 #define static
84 static volatile ScmObj l_current_dynamic_extent;
85 static volatile ScmObj l_continuation_stack;
86 static volatile ScmObj l_trace_stack;
87 #undef static
88 SCM_GLOBAL_VARS_END(static_continuation);
89 #define l_current_dynamic_extent \
90 SCM_GLOBAL_VAR(static_continuation, l_current_dynamic_extent)
91 #define l_continuation_stack \
92 SCM_GLOBAL_VAR(static_continuation, l_continuation_stack)
93 #define l_trace_stack \
94 SCM_GLOBAL_VAR(static_continuation, l_trace_stack)
95 SCM_DEFINE_STATIC_VARS(static_continuation);
96
97 /*=======================================
98 File Local Function Declarations
99 =======================================*/
100 /* dynamic extent */
101 static void initialize_dynamic_extent(void);
102 static void finalize_dynamic_extent(void);
103 static void wind_onto_dynamic_extent(ScmObj before, ScmObj after);
104 static void unwind_dynamic_extent(void);
105 static void enter_dynamic_extent(ScmObj dest);
106 static void exit_dynamic_extent(ScmObj dest);
107
108 /* continuation */
109 static void initialize_continuation_env(void);
110 static void finalize_continuation_env(void);
111 static void continuation_stack_push(ScmObj cont);
112 static ScmObj continuation_stack_pop(void);
113 static ScmObj continuation_stack_unwind(ScmObj dest_cont);
114
115 /*=======================================
116 Function Definitions
117 =======================================*/
118 SCM_EXPORT void
scm_init_continuation(void)119 scm_init_continuation(void)
120 {
121 SCM_GLOBAL_VARS_INIT(static_continuation);
122
123 initialize_dynamic_extent();
124 initialize_continuation_env();
125
126 scm_gc_protect_with_init((ScmObj *)&l_trace_stack, SCM_NULL);
127 }
128
129 SCM_EXPORT void
scm_fin_continuation(void)130 scm_fin_continuation(void)
131 {
132 finalize_continuation_env();
133 finalize_dynamic_extent();
134
135 SCM_GLOBAL_VARS_FIN(static_continuation);
136 }
137
138 /*===========================================================================
139 Dynamic Extent
140 ===========================================================================*/
141 #define MAKE_DYNEXT_FRAME(before, after) CONS((before), (after))
142 #define DYNEXT_FRAME_BEFORE CAR
143 #define DYNEXT_FRAME_AFTER CDR
144
145 static void
initialize_dynamic_extent(void)146 initialize_dynamic_extent(void)
147 {
148 scm_gc_protect_with_init((ScmObj *)&l_current_dynamic_extent, SCM_NULL);
149 }
150
151 static void
finalize_dynamic_extent(void)152 finalize_dynamic_extent(void)
153 {
154 }
155
156 static void
wind_onto_dynamic_extent(ScmObj before,ScmObj after)157 wind_onto_dynamic_extent(ScmObj before, ScmObj after)
158 {
159 ScmObj frame;
160
161 frame = MAKE_DYNEXT_FRAME(before, after);
162 l_current_dynamic_extent = CONS(frame, l_current_dynamic_extent);
163 }
164
165 static void
unwind_dynamic_extent(void)166 unwind_dynamic_extent(void)
167 {
168 if (NULLP(l_current_dynamic_extent))
169 PLAIN_ERR("corrupted dynamic extent");
170
171 l_current_dynamic_extent = CDR(l_current_dynamic_extent);
172 }
173
174 /* enter a dynamic extent of another continuation (dest) */
175 static void
enter_dynamic_extent(ScmObj dest)176 enter_dynamic_extent(ScmObj dest)
177 {
178 ScmObj frame, unwound, retpath;
179 DECLARE_INTERNAL_FUNCTION("enter_dynamic_extent");
180
181 retpath = SCM_NULL;
182 unwound = dest;
183 while (!NULLP(unwound) && !EQ(unwound, l_current_dynamic_extent)) {
184 frame = POP(unwound);
185 retpath = CONS(frame, retpath);
186 }
187
188 FOR_EACH (frame, retpath)
189 scm_call(DYNEXT_FRAME_BEFORE(frame), SCM_NULL);
190 }
191
192 /* exit to a dynamic extent of another continuation (dest) */
193 static void
exit_dynamic_extent(ScmObj dest)194 exit_dynamic_extent(ScmObj dest)
195 {
196 ScmObj frame;
197 DECLARE_INTERNAL_FUNCTION("exit_dynamic_extent");
198
199 while (!NULLP(l_current_dynamic_extent)
200 && !EQ(l_current_dynamic_extent, dest))
201 {
202 frame = POP(l_current_dynamic_extent);
203 scm_call(DYNEXT_FRAME_AFTER(frame), SCM_NULL);
204 }
205 }
206
207 SCM_EXPORT ScmObj
scm_dynamic_wind(ScmObj before,ScmObj thunk,ScmObj after)208 scm_dynamic_wind(ScmObj before, ScmObj thunk, ScmObj after)
209 {
210 ScmObj ret;
211
212 scm_call(before, SCM_NULL);
213
214 wind_onto_dynamic_extent(before, after);
215 ret = scm_call(thunk, SCM_NULL);
216 unwind_dynamic_extent();
217
218 scm_call(after, SCM_NULL);
219
220 return ret;
221 }
222
223 /*===========================================================================
224 Continuation
225 ===========================================================================*/
226 static void
initialize_continuation_env(void)227 initialize_continuation_env(void)
228 {
229 scm_gc_protect_with_init((ScmObj *)&l_continuation_stack, SCM_NULL);
230 }
231
232 static void
finalize_continuation_env(void)233 finalize_continuation_env(void)
234 {
235 }
236
237 static void
continuation_stack_push(ScmObj cont)238 continuation_stack_push(ScmObj cont)
239 {
240 l_continuation_stack = CONS(cont, l_continuation_stack);
241 }
242
243 static ScmObj
continuation_stack_pop(void)244 continuation_stack_pop(void)
245 {
246 DECLARE_INTERNAL_FUNCTION("continuation_stack_pop");
247
248 return NULLP(l_continuation_stack) ? SCM_FALSE : POP(l_continuation_stack);
249 }
250
251 /* expire all descendant continuations and dest_cont */
252 static ScmObj
continuation_stack_unwind(ScmObj dest_cont)253 continuation_stack_unwind(ScmObj dest_cont)
254 {
255 ScmObj cont;
256
257 do {
258 cont = continuation_stack_pop();
259 if (FALSEP(cont))
260 return SCM_FALSE;
261 CONTINUATION_SET_FRAME(cont, INVALID_CONTINUATION_OPAQUE);
262 } while (!EQ(dest_cont, cont));
263
264 return dest_cont;
265 }
266
267 SCM_EXPORT void
scm_destruct_continuation(ScmObj cont)268 scm_destruct_continuation(ScmObj cont)
269 {
270 /* no object to be free(3) in this implementation */
271 }
272
273 SCM_EXPORT ScmObj
scm_call_with_current_continuation(ScmObj proc,ScmEvalState * eval_state)274 scm_call_with_current_continuation(ScmObj proc, ScmEvalState *eval_state)
275 {
276 volatile ScmObj cont, ret;
277 struct scm_continuation_frame cont_frame;
278
279 cont_frame.dyn_ext = l_current_dynamic_extent;
280 cont_frame.ret_val = SCM_UNDEF;
281 #if SCM_USE_BACKTRACE
282 cont_frame.trace_stack = l_trace_stack;
283 #endif
284 cont = MAKE_CONTINUATION();
285 CONTINUATION_SET_FRAME(cont, &cont_frame);
286 #if SCM_NESTED_CONTINUATION_ONLY
287 continuation_stack_push(cont);
288 #endif
289
290 if (SETJMP(cont_frame.c_env)) {
291 /* returned back to the original continuation */
292 /* Don't refer cont because it may already be invalidated by
293 * continuation_stack_unwind(). */
294 #if SCM_USE_BACKTRACE
295 l_trace_stack = cont_frame.trace_stack;
296 #endif
297
298 enter_dynamic_extent(cont_frame.dyn_ext);
299
300 eval_state->ret_type = SCM_VALTYPE_AS_IS;
301 return cont_frame.ret_val;
302 } else {
303 #if SCM_NESTED_CONTINUATION_ONLY
304 /* Call proc with current continutation as (proc cont): This call must
305 * not be scm_values_applier, to preserve current stack until longjmp()
306 * is called. And so this implementation is not properly recursive. */
307 eval_state->ret_type = SCM_VALTYPE_AS_IS;
308 ret = scm_call(proc, LIST_1(cont));
309
310 /* the continuation expires when this function returned */
311 continuation_stack_unwind(cont);
312 #else
313 /* ONLY FOR TESTING: This call is properly recursible, but all
314 * continuations are broken and cannot be called, if the continuation
315 * is implemented by longjmp(). */
316 ret = LIST_3(scm_values_applier, proc, cont);
317 #endif
318
319 return ret;
320 }
321 }
322
323 SCM_EXPORT void
scm_call_continuation(ScmObj cont,ScmObj ret)324 scm_call_continuation(ScmObj cont, ScmObj ret)
325 {
326 struct scm_continuation_frame *frame;
327 #if SCM_NESTED_CONTINUATION_ONLY
328 ScmObj dst;
329 #endif
330 DECLARE_INTERNAL_FUNCTION("scm_call_continuation");
331
332 frame = CONTINUATION_FRAME(cont);
333
334 if (frame != INVALID_CONTINUATION_OPAQUE
335 #if SCM_NESTED_CONTINUATION_ONLY
336 && (dst = continuation_stack_unwind(cont), CONTINUATIONP(dst))
337 #endif
338 )
339 {
340 /* Don't refer cont because it may already be invalidated by
341 * continuation_stack_unwind(). */
342 exit_dynamic_extent(frame->dyn_ext);
343
344 frame->ret_val = ret;
345 LONGJMP(frame->c_env, scm_true);
346 /* NOTREACHED */
347 } else {
348 ERR("expired continuation");
349 }
350 }
351
352 /*===========================================================================
353 Trace Stack
354 ===========================================================================*/
355 #if SCM_USE_BACKTRACE
356 SCM_EXPORT void
scm_push_trace_frame(ScmObj obj,ScmObj env)357 scm_push_trace_frame(ScmObj obj, ScmObj env)
358 {
359 ScmObj frame;
360
361 frame = MAKE_TRACE_FRAME(obj, env);
362 l_trace_stack = CONS(frame, l_trace_stack);
363 }
364
365 SCM_EXPORT void
scm_pop_trace_frame(void)366 scm_pop_trace_frame(void)
367 {
368 SCM_ASSERT(CONSP(l_trace_stack));
369
370 l_trace_stack = CDR(l_trace_stack);
371 }
372 #endif /* SCM_USE_BACKTRACE */
373
374 SCM_EXPORT ScmObj
scm_trace_stack(void)375 scm_trace_stack(void)
376 {
377 return l_trace_stack;
378 }
379