1 /* Copyright (C) 2010, 2011 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"
35 scm_c_make_prompt (SCM k
, SCM
*fp
, SCM
*sp
, scm_t_uint8
*abort_ip
,
36 scm_t_uint8 escape_only_p
, scm_t_int64 vm_cookie
,
40 struct scm_prompt_registers
*regs
;
44 tag
|= (SCM_F_PROMPT_ESCAPE
<<8);
46 regs
= scm_gc_malloc_pointerless (sizeof (*regs
), "prompt registers");
50 regs
->cookie
= vm_cookie
;
52 return scm_double_cell (tag
, SCM_UNPACK (k
), (scm_t_bits
)regs
,
56 /* Only to be called if the SCM_PROMPT_SETJMP returns 1 */
58 scm_i_prompt_pop_abort_args_x (SCM vm
)
63 n
= scm_to_size_t (SCM_VM_DATA (vm
)->sp
[0]);
64 for (i
= 0; i
< n
; i
++)
65 vals
= scm_cons (SCM_VM_DATA (vm
)->sp
[-(i
+ 1)], vals
);
67 /* The abort did reset the VM's registers, but then these values
68 were pushed on; so we need to pop them ourselves. */
69 SCM_VM_DATA (vm
)->sp
-= n
+ 1;
76 #ifdef WORDS_BIGENDIAN
77 #define OBJCODE_HEADER(main,meta) 0, 0, 0, main, 0, 0, 0, meta+8
78 #define META_HEADER(meta) 0, 0, 0, meta, 0, 0, 0, 0
80 #define OBJCODE_HEADER(main,meta) main, 0, 0, 0, meta+8, 0, 0, 0
81 #define META_HEADER(meta) meta, 0, 0, 0, 0, 0, 0, 0
84 #define ALIGN_PTR(type,p,align) (type*)(ROUND_UP (((scm_t_bits)p), align))
87 #define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym) \
88 static const type sym[]
89 #define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym) \
90 static SCM_ALIGNED (alignment) const type sym[]
92 #define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym) \
94 #define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym) \
95 SCM_SNARF_INIT(sym = scm_malloc_pointerless (sizeof(sym##__unaligned); \
96 memcpy (sym, sym##__unaligned, sizeof(sym##__unaligned));) \
97 static type *sym = NULL; \
98 static const type sym##__unaligned[]
101 #define STATIC_OBJCODE_TAG \
102 SCM_PACK (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_STATIC, 0))
104 #define SCM_STATIC_OBJCODE(sym) \
105 SCM_DECLARE_STATIC_ALIGNED_ARRAY (scm_t_uint8, sym##__bytecode); \
106 SCM_STATIC_ALIGNED_ARRAY (8, scm_t_cell, sym##__cells) = { \
107 { STATIC_OBJCODE_TAG, SCM_PACK (sym##__bytecode) }, \
108 { SCM_BOOL_F, SCM_PACK (0) } \
110 static const SCM sym = SCM_PACK (sym##__cells); \
111 SCM_STATIC_ALIGNED_ARRAY (8, scm_t_uint8, sym##__bytecode)
114 SCM_STATIC_OBJCODE (cont_objcode
) = {
115 /* Like in continuations.c, but with partial-cont-call. */
116 OBJCODE_HEADER (8, 19),
117 /* leave args on the stack */
118 /* 0 */ scm_op_object_ref
, 0, /* push scm_vm_cont object */
119 /* 2 */ scm_op_object_ref
, 1, /* push internal winds */
120 /* 4 */ scm_op_partial_cont_call
, /* and go! */
121 /* 5 */ scm_op_nop
, scm_op_nop
, scm_op_nop
, /* pad to 8 bytes */
124 /* We could put some meta-info to say that this proc is a continuation. Not sure
125 how to do that, though. */
127 /* 0 */ scm_op_make_eol
, /* bindings */
128 /* 1 */ scm_op_make_eol
, /* sources */
129 /* 2 */ scm_op_make_int8
, 0, scm_op_make_int8
, 5, /* arity: from ip 0 to ip 7 */
130 /* 6 */ scm_op_make_int8_0
, /* the arity is 0 required args */
131 /* 7 */ scm_op_make_int8_0
, /* 0 optionals */
132 /* 8 */ scm_op_make_true
, /* and a rest arg */
133 /* 9 */ scm_op_list
, 0, 5, /* make a list of those 5 vals */
134 /* 12 */ scm_op_list
, 0, 1, /* and the arities will be a list of that one list */
135 /* 15 */ scm_op_list
, 0, 3, /* pack bindings, sources, and arities into list */
136 /* 18 */ scm_op_return
/* and return */
142 reify_partial_continuation (SCM vm
, SCM prompt
, SCM extwinds
,
145 SCM vm_cont
, dynwinds
, intwinds
= SCM_EOL
, ret
;
148 /* No need to reify if the continuation is never referenced in the handler. */
149 if (SCM_PROMPT_ESCAPE_P (prompt
))
152 dynwinds
= scm_i_dynwinds ();
153 while (!scm_is_eq (dynwinds
, extwinds
))
155 intwinds
= scm_cons (scm_car (dynwinds
), intwinds
);
156 dynwinds
= scm_cdr (dynwinds
);
159 flags
= SCM_F_VM_CONT_PARTIAL
;
160 if (cookie
>= 0 && SCM_PROMPT_REGISTERS (prompt
)->cookie
== cookie
)
161 flags
|= SCM_F_VM_CONT_REWINDABLE
;
163 /* Since non-escape continuations should begin with a thunk application, the
164 first bit of the stack should be a frame, with the saved fp equal to the fp
165 that was current when the prompt was made. */
166 if ((SCM
*)(SCM_PROMPT_REGISTERS (prompt
)->sp
[1])
167 != SCM_PROMPT_REGISTERS (prompt
)->fp
)
170 /* Capture from the top of the thunk application frame up to the end. Set an
171 MVRA only, as the post-abort code is in an MV context. */
172 vm_cont
= scm_i_vm_capture_stack (SCM_PROMPT_REGISTERS (prompt
)->sp
+ 4,
173 SCM_VM_DATA (vm
)->fp
,
174 SCM_VM_DATA (vm
)->sp
,
176 SCM_VM_DATA (vm
)->ip
,
179 ret
= scm_make_program (cont_objcode
,
180 scm_vector (scm_list_2 (vm_cont
, intwinds
)),
182 SCM_SET_CELL_WORD_0 (ret
,
183 SCM_CELL_WORD_0 (ret
) | SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION
);
188 scm_c_abort (SCM vm
, SCM tag
, size_t n
, SCM
*argv
, scm_t_int64 cookie
)
190 SCM cont
, winds
, prompt
= SCM_BOOL_F
;
194 /* Search the wind list for an appropriate prompt.
195 "Waiter, please bring us the wind list." */
196 for (winds
= scm_i_dynwinds (), delta
= 0;
198 winds
= SCM_CDR (winds
), delta
++)
200 SCM elt
= SCM_CAR (winds
);
201 if (SCM_PROMPT_P (elt
) && scm_is_eq (SCM_PROMPT_TAG (elt
), tag
))
208 /* If we didn't find anything, raise an error. */
209 if (scm_is_false (prompt
))
210 scm_misc_error ("abort", "Abort to unknown prompt", scm_list_1 (tag
));
212 cont
= reify_partial_continuation (vm
, prompt
, winds
, cookie
);
214 /* Unwind once more, beyond the prompt. */
215 winds
= SCM_CDR (winds
), delta
++;
218 scm_dowinds (winds
, delta
);
220 /* Unwinding may have changed the current thread's VM, so use the
224 /* Restore VM regs */
225 SCM_VM_DATA (vm
)->fp
= SCM_PROMPT_REGISTERS (prompt
)->fp
;
226 SCM_VM_DATA (vm
)->sp
= SCM_PROMPT_REGISTERS (prompt
)->sp
;
227 SCM_VM_DATA (vm
)->ip
= SCM_PROMPT_REGISTERS (prompt
)->ip
;
229 /* Since we're jumping down, we should always have enough space */
230 if (SCM_VM_DATA (vm
)->sp
+ n
+ 1 >= SCM_VM_DATA (vm
)->stack_limit
)
234 *(++(SCM_VM_DATA (vm
)->sp
)) = cont
;
235 for (i
= 0; i
< n
; i
++)
236 *(++(SCM_VM_DATA (vm
)->sp
)) = argv
[i
];
237 *(++(SCM_VM_DATA (vm
)->sp
)) = scm_from_size_t (n
+1); /* +1 for continuation */
240 SCM_I_LONGJMP (SCM_PROMPT_REGISTERS (prompt
)->regs
, 1);
242 /* Shouldn't get here */
246 SCM_DEFINE (scm_at_abort
, "@abort", 2, 0, 0, (SCM tag
, SCM args
),
247 "Abort to the nearest prompt with tag @var{tag}.")
248 #define FUNC_NAME s_scm_at_abort
253 SCM_VALIDATE_LIST_COPYLEN (SCM_ARG2
, args
, n
);
254 argv
= alloca (sizeof (SCM
)*n
);
255 for (i
= 0; i
< n
; i
++, args
= scm_cdr (args
))
256 argv
[i
] = scm_car (args
);
258 scm_c_abort (scm_the_vm (), tag
, n
, argv
, -1);
260 /* Oh, what, you're still here? The abort must have been reinstated. Actually,
261 that's quite impossible, given that we're already in C-land here, so...
269 scm_i_prompt_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
271 scm_puts ("#<prompt ", port
);
272 scm_intprint (SCM_UNPACK (exp
), 16, port
);
273 scm_putc ('>', port
);
277 scm_init_control (void)
279 #include "libguile/control.x"