1 /* Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
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.
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.
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
25 #include "libguile/_scm.h"
26 #include "libguile/control.h"
27 #include "libguile/objcodes.h"
28 #include "libguile/instructions.h"
29 #include "libguile/vm.h"
33 #define PROMPT_ESCAPE_P(p) \
34 (SCM_DYNSTACK_TAG_FLAGS (SCM_DYNSTACK_TAG (p)) \
35 & SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY)
40 /* Only to be called if the SCM_I_SETJMP returns 1 */
42 scm_i_prompt_pop_abort_args_x (SCM vm
)
47 n
= scm_to_size_t (SCM_VM_DATA (vm
)->sp
[0]);
48 for (i
= 0; i
< n
; i
++)
49 vals
= scm_cons (SCM_VM_DATA (vm
)->sp
[-(i
+ 1)], vals
);
51 /* The abort did reset the VM's registers, but then these values
52 were pushed on; so we need to pop them ourselves. */
53 SCM_VM_DATA (vm
)->sp
-= n
+ 1;
60 #ifdef WORDS_BIGENDIAN
61 #define OBJCODE_HEADER(main,meta) 0, 0, 0, main, 0, 0, 0, meta+8
62 #define META_HEADER(meta) 0, 0, 0, meta, 0, 0, 0, 0
64 #define OBJCODE_HEADER(main,meta) main, 0, 0, 0, meta+8, 0, 0, 0
65 #define META_HEADER(meta) meta, 0, 0, 0, 0, 0, 0, 0
68 #define OBJCODE_TAG SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_STATIC, 0)
70 #if defined (SCM_ALIGNED)
71 #define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym) \
72 static const type sym[]
73 #define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym) \
74 static SCM_ALIGNED (alignment) const type sym[]
75 #define SCM_STATIC_OBJCODE(sym) \
76 SCM_DECLARE_STATIC_ALIGNED_ARRAY (scm_t_uint8, sym##__bytecode); \
77 SCM_STATIC_ALIGNED_ARRAY (8, scm_t_cell, sym##__cells) = { \
78 { SCM_PACK (OBJCODE_TAG), SCM_PACK (sym##__bytecode) }, \
79 { SCM_BOOL_F, SCM_PACK (0) } \
81 static const SCM sym = SCM_PACK (sym##__cells); \
82 SCM_STATIC_ALIGNED_ARRAY (8, scm_t_uint8, sym##__bytecode)
84 #define SCM_STATIC_OBJCODE(sym) \
86 static scm_t_uint8 *sym##_bytecode; \
87 SCM_SNARF_INIT(sym##_bytecode = scm_gc_malloc_pointerless (sizeof(sym##_bytecode__unaligned), "partial continuation stub"); \
88 memcpy (sym##_bytecode, sym##_bytecode__unaligned, sizeof(sym##_bytecode__unaligned));) \
89 SCM_SNARF_INIT(sym = scm_double_cell (OBJCODE_TAG, \
90 (scm_t_bits)sym##_bytecode, \
91 SCM_UNPACK (SCM_BOOL_F), \
93 static const scm_t_uint8 sym##_bytecode__unaligned[]
97 SCM_STATIC_OBJCODE (cont_objcode
) = {
98 /* Like in continuations.c, but with partial-cont-call. */
99 OBJCODE_HEADER (8, 19),
100 /* leave args on the stack */
101 /* 0 */ scm_op_object_ref
, 0, /* push scm_vm_cont object */
102 /* 2 */ scm_op_partial_cont_call
, /* and go! */
104 /* 4 */ scm_op_nop
, scm_op_nop
, scm_op_nop
, scm_op_nop
, /* pad to 8 bytes */
107 /* We could put some meta-info to say that this proc is a continuation. Not sure
108 how to do that, though. */
110 /* 0 */ scm_op_make_eol
, /* bindings */
111 /* 1 */ scm_op_make_eol
, /* sources */
112 /* 2 */ scm_op_make_int8
, 0, scm_op_make_int8
, 3, /* arity: from ip 0 to ip 3 */
113 /* 6 */ scm_op_make_int8_0
, /* the arity is 0 required args */
114 /* 7 */ scm_op_make_int8_0
, /* 0 optionals */
115 /* 8 */ scm_op_make_true
, /* and a rest arg */
116 /* 9 */ scm_op_list
, 0, 5, /* make a list of those 5 vals */
117 /* 12 */ scm_op_list
, 0, 1, /* and the arities will be a list of that one list */
118 /* 15 */ scm_op_list
, 0, 3, /* pack bindings, sources, and arities into list */
119 /* 18 */ scm_op_return
/* and return */
125 reify_partial_continuation (SCM vm
,
126 SCM
*saved_fp
, SCM
*saved_sp
, scm_t_uint8
*saved_ip
,
127 scm_i_jmp_buf
*saved_registers
,
128 scm_t_dynstack
*dynstack
,
129 scm_i_jmp_buf
*current_registers
)
134 flags
= SCM_F_VM_CONT_PARTIAL
;
135 /* If we are aborting to a prompt that has the same registers as those
136 of the abort, it means there are no intervening C frames on the
137 stack, and so the continuation can be relocated elsewhere on the
138 stack: it is rewindable. */
139 if (saved_registers
&& saved_registers
== current_registers
)
140 flags
|= SCM_F_VM_CONT_REWINDABLE
;
142 /* Since non-escape continuations should begin with a thunk application, the
143 first bit of the stack should be a frame, with the saved fp equal to the fp
144 that was current when the prompt was made. */
145 if ((SCM
*)SCM_UNPACK (saved_sp
[1]) != saved_fp
)
148 /* Capture from the top of the thunk application frame up to the end. Set an
149 MVRA only, as the post-abort code is in an MV context. */
150 vm_cont
= scm_i_vm_capture_stack (saved_sp
+ 4,
151 SCM_VM_DATA (vm
)->fp
,
152 SCM_VM_DATA (vm
)->sp
,
154 SCM_VM_DATA (vm
)->ip
,
158 ret
= scm_make_program (cont_objcode
,
159 scm_c_make_vector (1, vm_cont
),
161 SCM_SET_CELL_WORD_0 (ret
,
162 SCM_CELL_WORD_0 (ret
) | SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION
);
167 scm_c_abort (SCM vm
, SCM tag
, size_t n
, SCM
*argv
,
168 scm_i_jmp_buf
*current_registers
)
171 scm_t_dynstack
*dynstack
= &SCM_I_CURRENT_THREAD
->dynstack
;
173 scm_t_dynstack_prompt_flags flags
;
176 scm_i_jmp_buf
*registers
;
179 prompt
= scm_dynstack_find_prompt (dynstack
, tag
,
180 &flags
, &fp
, &sp
, &ip
, ®isters
);
183 scm_misc_error ("abort", "Abort to unknown prompt", scm_list_1 (tag
));
185 /* Only reify if the continuation referenced in the handler. */
186 if (flags
& SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
)
190 scm_t_dynstack
*captured
;
192 captured
= scm_dynstack_capture (dynstack
, SCM_DYNSTACK_NEXT (prompt
));
193 cont
= reify_partial_continuation (vm
, fp
, sp
, ip
, registers
, captured
,
198 scm_dynstack_unwind (dynstack
, prompt
);
200 /* Unwinding may have changed the current thread's VM, so use the
204 /* Restore VM regs */
205 SCM_VM_DATA (vm
)->fp
= fp
;
206 SCM_VM_DATA (vm
)->sp
= sp
;
207 SCM_VM_DATA (vm
)->ip
= ip
;
209 /* Since we're jumping down, we should always have enough space. */
210 if (SCM_VM_DATA (vm
)->sp
+ n
+ 1 >= SCM_VM_DATA (vm
)->stack_limit
)
214 *(++(SCM_VM_DATA (vm
)->sp
)) = cont
;
215 for (i
= 0; i
< n
; i
++)
216 *(++(SCM_VM_DATA (vm
)->sp
)) = argv
[i
];
217 *(++(SCM_VM_DATA (vm
)->sp
)) = scm_from_size_t (n
+1); /* +1 for continuation */
220 SCM_I_LONGJMP (*registers
, 1);
222 /* Shouldn't get here */
226 SCM_DEFINE (scm_at_abort
, "@abort", 2, 0, 0, (SCM tag
, SCM args
),
227 "Abort to the nearest prompt with tag @var{tag}.")
228 #define FUNC_NAME s_scm_at_abort
234 SCM_VALIDATE_LIST_COPYLEN (SCM_ARG2
, args
, n
);
235 argv
= alloca (sizeof (SCM
)*n
);
236 for (i
= 0; i
< n
; i
++, args
= scm_cdr (args
))
237 argv
[i
] = scm_car (args
);
239 scm_c_abort (scm_the_vm (), tag
, n
, argv
, NULL
);
241 /* Oh, what, you're still here? The abort must have been reinstated. Actually,
242 that's quite impossible, given that we're already in C-land here, so...
250 scm_init_control (void)
252 #include "libguile/control.x"