1 /* Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
2 *
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
7 *
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
12 *
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
16 * 02110-1301 USA
17 */
18
19 #if HAVE_CONFIG_H
20 # include <config.h>
21 #endif
22
23 #include <alloca.h>
24
25 #include "libguile/_scm.h"
26 #include "libguile/control.h"
27 #include "libguile/programs.h"
28 #include "libguile/instructions.h"
29 #include "libguile/vm.h"
30
31
32
33 #define PROMPT_ESCAPE_P(p) \
34 (SCM_DYNSTACK_TAG_FLAGS (SCM_DYNSTACK_TAG (p)) \
35 & SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY)
36
37
38
39
40 /* Only to be called if the SCM_I_SETJMP returns 1 */
41 SCM
scm_i_prompt_pop_abort_args_x(struct scm_vm * vp,scm_t_ptrdiff saved_stack_depth)42 scm_i_prompt_pop_abort_args_x (struct scm_vm *vp,
43 scm_t_ptrdiff saved_stack_depth)
44 {
45 size_t i, n;
46 scm_t_ptrdiff stack_depth;
47 SCM vals = SCM_EOL;
48
49 stack_depth = vp->stack_top - vp->sp;
50 if (stack_depth < saved_stack_depth)
51 abort ();
52 n = stack_depth - saved_stack_depth;
53
54 for (i = 0; i < n; i++)
55 vals = scm_cons (vp->sp[i].as_scm, vals);
56
57 vp->sp += n;
58
59 return vals;
60 }
61
62
63 static const scm_t_uint32 compose_continuation_code[] =
64 {
65 SCM_PACK_OP_24 (compose_continuation, 0)
66 };
67
68
69 static SCM
make_partial_continuation(SCM vm_cont)70 make_partial_continuation (SCM vm_cont)
71 {
72 scm_t_bits nfree = 1;
73 scm_t_bits flags = SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION;
74 SCM ret;
75
76 ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2);
77 SCM_SET_CELL_WORD_1 (ret, compose_continuation_code);
78 SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, vm_cont);
79
80 return ret;
81 }
82
83 static SCM
reify_partial_continuation(struct scm_vm * vp,union scm_vm_stack_element * saved_fp,union scm_vm_stack_element * saved_sp,scm_t_uint32 * saved_ip,scm_i_jmp_buf * saved_registers,scm_t_dynstack * dynstack,scm_i_jmp_buf * current_registers)84 reify_partial_continuation (struct scm_vm *vp,
85 union scm_vm_stack_element *saved_fp,
86 union scm_vm_stack_element *saved_sp,
87 scm_t_uint32 *saved_ip,
88 scm_i_jmp_buf *saved_registers,
89 scm_t_dynstack *dynstack,
90 scm_i_jmp_buf *current_registers)
91 {
92 SCM vm_cont;
93 scm_t_uint32 flags;
94 union scm_vm_stack_element *base_fp;
95
96 flags = SCM_F_VM_CONT_PARTIAL;
97 /* If we are aborting to a prompt that has the same registers as those
98 of the abort, it means there are no intervening C frames on the
99 stack, and so the continuation can be relocated elsewhere on the
100 stack: it is rewindable. */
101 if (saved_registers && saved_registers == current_registers)
102 flags |= SCM_F_VM_CONT_REWINDABLE;
103
104 /* Walk the stack until we find the first frame newer than saved_fp.
105 We will save the stack until that frame. It used to be that we
106 could determine the stack base in O(1) time, but that's no longer
107 the case, since the thunk application doesn't occur where the
108 prompt is saved. */
109 for (base_fp = vp->fp;
110 SCM_FRAME_DYNAMIC_LINK (base_fp) < saved_fp;
111 base_fp = SCM_FRAME_DYNAMIC_LINK (base_fp));
112
113 if (SCM_FRAME_DYNAMIC_LINK (base_fp) != saved_fp)
114 abort();
115
116 scm_dynstack_relocate_prompts (dynstack, vp->stack_top - base_fp);
117
118 /* Capture from the base_fp to the top thunk application frame. */
119 vm_cont = scm_i_vm_capture_stack (base_fp, vp->fp, vp->sp, vp->ip, dynstack,
120 flags);
121
122 return make_partial_continuation (vm_cont);
123 }
124
125 void
scm_c_abort(struct scm_vm * vp,SCM tag,size_t n,SCM * argv,scm_i_jmp_buf * current_registers)126 scm_c_abort (struct scm_vm *vp, SCM tag, size_t n, SCM *argv,
127 scm_i_jmp_buf *current_registers)
128 {
129 SCM cont;
130 scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack;
131 scm_t_bits *prompt;
132 scm_t_dynstack_prompt_flags flags;
133 scm_t_ptrdiff fp_offset, sp_offset;
134 union scm_vm_stack_element *fp, *sp;
135 scm_t_uint32 *ip;
136 scm_i_jmp_buf *registers;
137 size_t i;
138
139 prompt = scm_dynstack_find_prompt (dynstack, tag,
140 &flags, &fp_offset, &sp_offset, &ip,
141 ®isters);
142
143 if (!prompt)
144 scm_misc_error ("abort", "Abort to unknown prompt", scm_list_1 (tag));
145
146 fp = vp->stack_top - fp_offset;
147 sp = vp->stack_top - sp_offset;
148
149 /* Only reify if the continuation referenced in the handler. */
150 if (flags & SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY)
151 cont = SCM_BOOL_F;
152 else
153 {
154 scm_t_dynstack *captured;
155
156 captured = scm_dynstack_capture (dynstack, SCM_DYNSTACK_NEXT (prompt));
157 cont = reify_partial_continuation (vp, fp, sp, ip, registers, captured,
158 current_registers);
159 }
160
161 /* Unwind. */
162 scm_dynstack_unwind (dynstack, prompt);
163
164 /* Restore VM regs */
165 vp->fp = fp;
166 vp->sp = sp - n - 1;
167 vp->ip = ip;
168
169 /* Since we're jumping down, we should always have enough space. */
170 if (vp->sp < vp->stack_limit)
171 abort ();
172
173 /* Push vals */
174 vp->sp[n].as_scm = cont;
175 for (i = 0; i < n; i++)
176 vp->sp[n - i - 1].as_scm = argv[i];
177
178 /* Jump! */
179 SCM_I_LONGJMP (*registers, 1);
180
181 /* Shouldn't get here */
182 abort ();
183 }
184
185 SCM_DEFINE (scm_abort_to_prompt_star, "abort-to-prompt*", 2, 0, 0,
186 (SCM tag, SCM args),
187 "Abort to the nearest prompt with tag @var{tag}, yielding the\n"
188 "values in the list, @var{args}.")
189 #define FUNC_NAME s_scm_abort_to_prompt_star
190 {
191 SCM *argv;
192 size_t i;
193 long n;
194
195 SCM_VALIDATE_LIST_COPYLEN (SCM_ARG2, args, n);
196 argv = alloca (sizeof (SCM)*n);
197 for (i = 0; i < n; i++, args = scm_cdr (args))
198 argv[i] = scm_car (args);
199
200 scm_c_abort (scm_the_vm (), tag, n, argv, NULL);
201
202 /* Oh, what, you're still here? The abort must have been reinstated. Actually,
203 that's quite impossible, given that we're already in C-land here, so...
204 abort! */
205
206 abort ();
207 }
208 #undef FUNC_NAME
209
210 static SCM
scm_suspendable_continuation_p(SCM tag)211 scm_suspendable_continuation_p (SCM tag)
212 {
213 scm_t_dynstack_prompt_flags flags;
214 scm_i_thread *thread = SCM_I_CURRENT_THREAD;
215 scm_i_jmp_buf *registers;
216
217 if (scm_dynstack_find_prompt (&thread->dynstack, tag, &flags,
218 NULL, NULL, NULL, ®isters))
219 return scm_from_bool (registers == thread->vp->resumable_prompt_cookie);
220
221 return SCM_BOOL_F;
222 }
223
224 static void
scm_init_ice_9_control(void * unused)225 scm_init_ice_9_control (void *unused)
226 {
227 scm_c_define_gsubr ("suspendable-continuation?", 1, 0, 0,
228 scm_suspendable_continuation_p);
229 }
230
231 void
scm_init_control(void)232 scm_init_control (void)
233 {
234 #include "libguile/control.x"
235
236 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
237 "scm_init_ice_9_control", scm_init_ice_9_control,
238 NULL);
239 }
240
241 /*
242 Local Variables:
243 c-file-style: "gnu"
244 End:
245 */
246