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 scm_t_prompt_registers
*
41 scm_c_make_prompt_registers (SCM
*fp
, SCM
*sp
, scm_t_uint8
*abort_ip
,
42 scm_t_int64 vm_cookie
)
44 scm_t_prompt_registers
*regs
;
46 regs
= scm_gc_malloc_pointerless (sizeof (*regs
), "prompt registers");
50 regs
->cookie
= vm_cookie
;
55 /* Only to be called if the SCM_I_SETJMP returns 1 */
57 scm_i_prompt_pop_abort_args_x (SCM vm
)
62 n
= scm_to_size_t (SCM_VM_DATA (vm
)->sp
[0]);
63 for (i
= 0; i
< n
; i
++)
64 vals
= scm_cons (SCM_VM_DATA (vm
)->sp
[-(i
+ 1)], vals
);
66 /* The abort did reset the VM's registers, but then these values
67 were pushed on; so we need to pop them ourselves. */
68 SCM_VM_DATA (vm
)->sp
-= n
+ 1;
75 #ifdef WORDS_BIGENDIAN
76 #define OBJCODE_HEADER(main,meta) 0, 0, 0, main, 0, 0, 0, meta+8
77 #define META_HEADER(meta) 0, 0, 0, meta, 0, 0, 0, 0
79 #define OBJCODE_HEADER(main,meta) main, 0, 0, 0, meta+8, 0, 0, 0
80 #define META_HEADER(meta) meta, 0, 0, 0, 0, 0, 0, 0
83 #define OBJCODE_TAG SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_STATIC, 0)
85 #if defined (SCM_ALIGNED)
86 #define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym) \
87 static const type sym[]
88 #define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym) \
89 static SCM_ALIGNED (alignment) const type sym[]
90 #define SCM_STATIC_OBJCODE(sym) \
91 SCM_DECLARE_STATIC_ALIGNED_ARRAY (scm_t_uint8, sym##__bytecode); \
92 SCM_STATIC_ALIGNED_ARRAY (8, scm_t_cell, sym##__cells) = { \
93 { SCM_PACK (OBJCODE_TAG), SCM_PACK (sym##__bytecode) }, \
94 { SCM_BOOL_F, SCM_PACK (0) } \
96 static const SCM sym = SCM_PACK (sym##__cells); \
97 SCM_STATIC_ALIGNED_ARRAY (8, scm_t_uint8, sym##__bytecode)
99 #define SCM_STATIC_OBJCODE(sym) \
101 static scm_t_uint8 *sym##_bytecode; \
102 SCM_SNARF_INIT(sym##_bytecode = scm_gc_malloc_pointerless (sizeof(sym##_bytecode__unaligned), "partial continuation stub"); \
103 memcpy (sym##_bytecode, sym##_bytecode__unaligned, sizeof(sym##_bytecode__unaligned));) \
104 SCM_SNARF_INIT(sym = scm_double_cell (OBJCODE_TAG, \
105 (scm_t_bits)sym##_bytecode, \
106 SCM_UNPACK (SCM_BOOL_F), \
108 static const scm_t_uint8 sym##_bytecode__unaligned[]
112 SCM_STATIC_OBJCODE (cont_objcode
) = {
113 /* Like in continuations.c, but with partial-cont-call. */
114 OBJCODE_HEADER (8, 19),
115 /* leave args on the stack */
116 /* 0 */ scm_op_object_ref
, 0, /* push scm_vm_cont object */
117 /* 2 */ scm_op_partial_cont_call
, /* and go! */
119 /* 4 */ scm_op_nop
, scm_op_nop
, scm_op_nop
, scm_op_nop
, /* pad to 8 bytes */
122 /* We could put some meta-info to say that this proc is a continuation. Not sure
123 how to do that, though. */
125 /* 0 */ scm_op_make_eol
, /* bindings */
126 /* 1 */ scm_op_make_eol
, /* sources */
127 /* 2 */ scm_op_make_int8
, 0, scm_op_make_int8
, 3, /* arity: from ip 0 to ip 3 */
128 /* 6 */ scm_op_make_int8_0
, /* the arity is 0 required args */
129 /* 7 */ scm_op_make_int8_0
, /* 0 optionals */
130 /* 8 */ scm_op_make_true
, /* and a rest arg */
131 /* 9 */ scm_op_list
, 0, 5, /* make a list of those 5 vals */
132 /* 12 */ scm_op_list
, 0, 1, /* and the arities will be a list of that one list */
133 /* 15 */ scm_op_list
, 0, 3, /* pack bindings, sources, and arities into list */
134 /* 18 */ scm_op_return
/* and return */
140 reify_partial_continuation (SCM vm
, scm_t_prompt_registers
*regs
,
141 scm_t_dynstack
*dynstack
,
147 flags
= SCM_F_VM_CONT_PARTIAL
;
148 if (cookie
>= 0 && regs
->cookie
== cookie
)
149 flags
|= SCM_F_VM_CONT_REWINDABLE
;
151 /* Since non-escape continuations should begin with a thunk application, the
152 first bit of the stack should be a frame, with the saved fp equal to the fp
153 that was current when the prompt was made. */
154 if ((SCM
*)SCM_UNPACK (regs
->sp
[1]) != regs
->fp
)
157 /* Capture from the top of the thunk application frame up to the end. Set an
158 MVRA only, as the post-abort code is in an MV context. */
159 vm_cont
= scm_i_vm_capture_stack (regs
->sp
+ 4,
160 SCM_VM_DATA (vm
)->fp
,
161 SCM_VM_DATA (vm
)->sp
,
163 SCM_VM_DATA (vm
)->ip
,
167 ret
= scm_make_program (cont_objcode
,
168 scm_c_make_vector (1, vm_cont
),
170 SCM_SET_CELL_WORD_0 (ret
,
171 SCM_CELL_WORD_0 (ret
) | SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION
);
176 scm_c_abort (SCM vm
, SCM tag
, size_t n
, SCM
*argv
, scm_t_int64 cookie
)
179 scm_t_dynstack
*dynstack
= &SCM_I_CURRENT_THREAD
->dynstack
;
181 scm_t_prompt_registers
*regs
;
182 scm_t_dynstack_prompt_flags flags
;
185 prompt
= scm_dynstack_find_prompt (dynstack
, tag
, ®s
, &flags
);
188 scm_misc_error ("abort", "Abort to unknown prompt", scm_list_1 (tag
));
190 /* Only reify if the continuation referenced in the handler. */
191 if (flags
& SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
)
195 scm_t_dynstack
*captured
;
197 captured
= scm_dynstack_capture (dynstack
, SCM_DYNSTACK_NEXT (prompt
));
198 cont
= reify_partial_continuation (vm
, regs
, captured
, cookie
);
202 scm_dynstack_unwind (dynstack
, prompt
);
204 /* Unwinding may have changed the current thread's VM, so use the
208 /* Restore VM regs */
209 SCM_VM_DATA (vm
)->fp
= regs
->fp
;
210 SCM_VM_DATA (vm
)->sp
= regs
->sp
;
211 SCM_VM_DATA (vm
)->ip
= regs
->ip
;
213 /* Since we're jumping down, we should always have enough space. */
214 if (SCM_VM_DATA (vm
)->sp
+ n
+ 1 >= SCM_VM_DATA (vm
)->stack_limit
)
218 *(++(SCM_VM_DATA (vm
)->sp
)) = cont
;
219 for (i
= 0; i
< n
; i
++)
220 *(++(SCM_VM_DATA (vm
)->sp
)) = argv
[i
];
221 *(++(SCM_VM_DATA (vm
)->sp
)) = scm_from_size_t (n
+1); /* +1 for continuation */
224 SCM_I_LONGJMP (regs
->regs
, 1);
226 /* Shouldn't get here */
230 SCM_DEFINE (scm_at_abort
, "@abort", 2, 0, 0, (SCM tag
, SCM args
),
231 "Abort to the nearest prompt with tag @var{tag}.")
232 #define FUNC_NAME s_scm_at_abort
238 SCM_VALIDATE_LIST_COPYLEN (SCM_ARG2
, args
, n
);
239 argv
= alloca (sizeof (SCM
)*n
);
240 for (i
= 0; i
< n
; i
++, args
= scm_cdr (args
))
241 argv
[i
] = scm_car (args
);
243 scm_c_abort (scm_the_vm (), tag
, n
, argv
, -1);
245 /* Oh, what, you're still here? The abort must have been reinstated. Actually,
246 that's quite impossible, given that we're already in C-land here, so...
254 scm_init_control (void)
256 #include "libguile/control.x"