1 /* Copyright (C) 2010 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
23 #include "libguile/_scm.h"
24 #include "libguile/control.h"
25 #include "libguile/objcodes.h"
26 #include "libguile/instructions.h"
27 #include "libguile/vm.h"
31 SCM scm_sys_default_prompt_tag
;
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 prompt
)
63 n
= scm_to_size_t (SCM_PROMPT_REGISTERS (prompt
)->sp
[0]);
64 for (i
= 0; i
< n
; i
++)
65 vals
= scm_cons (SCM_PROMPT_REGISTERS (prompt
)->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 (scm_the_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 ROUND_UP(len,align) (((len-1)|(align-1))+1)
85 #define ALIGN_PTR(type,p,align) (type*)(ROUND_UP (((scm_t_bits)p), align))
88 #define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym)\
89 static const type sym[]
90 #define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym)\
91 static SCM_ALIGNED (alignment) const type sym[]
93 #define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym)\
95 #define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym) \
96 SCM_SNARF_INIT(sym = scm_malloc (sizeof(sym##__unaligned) + alignment - 1); \
97 sym = ALIGN_PTR (type, sym, alignment); \
98 memcpy (sym, sym##__unaligned, sizeof(sym##__unaligned));) \
99 static type *sym = NULL; \
100 static const type sym##__unaligned[]
103 #define STATIC_OBJCODE_TAG \
104 SCM_PACK (scm_tc7_objcode | (SCM_F_OBJCODE_IS_STATIC << 8))
106 #define SCM_STATIC_OBJCODE(sym) \
107 SCM_DECLARE_STATIC_ALIGNED_ARRAY (scm_t_uint8, sym##__bytecode); \
108 SCM_STATIC_ALIGNED_ARRAY (8, scm_t_cell, sym##__cells) = { \
109 { STATIC_OBJCODE_TAG, SCM_PACK (sym##__bytecode) }, \
110 { SCM_BOOL_F, SCM_PACK (0) } \
112 static const SCM sym = SCM_PACK (sym##__cells); \
113 SCM_STATIC_ALIGNED_ARRAY (8, scm_t_uint8, sym##__bytecode)
116 SCM_STATIC_OBJCODE (cont_objcode
) = {
117 /* Like in continuations.c, but with partial-cont-call. */
118 OBJCODE_HEADER (8, 19),
119 /* leave args on the stack */
120 /* 0 */ scm_op_object_ref
, 0, /* push scm_vm_cont object */
121 /* 2 */ scm_op_object_ref
, 1, /* push internal winds */
122 /* 4 */ scm_op_partial_cont_call
, /* and go! */
123 /* 5 */ scm_op_nop
, scm_op_nop
, scm_op_nop
, /* pad to 8 bytes */
126 /* We could put some meta-info to say that this proc is a continuation. Not sure
127 how to do that, though. */
129 /* 0 */ scm_op_make_eol
, /* bindings */
130 /* 1 */ scm_op_make_eol
, /* sources */
131 /* 2 */ scm_op_make_int8
, 0, scm_op_make_int8
, 5, /* arity: from ip 0 to ip 7 */
132 /* 6 */ scm_op_make_int8_0
, /* the arity is 0 required args */
133 /* 7 */ scm_op_make_int8_0
, /* 0 optionals */
134 /* 8 */ scm_op_make_true
, /* and a rest arg */
135 /* 9 */ scm_op_list
, 0, 5, /* make a list of those 5 vals */
136 /* 12 */ scm_op_list
, 0, 1, /* and the arities will be a list of that one list */
137 /* 15 */ scm_op_list
, 0, 3, /* pack bindings, sources, and arities into list */
138 /* 18 */ scm_op_return
/* and return */
144 reify_partial_continuation (SCM vm
, SCM prompt
, SCM extwinds
,
147 SCM vm_cont
, dynwinds
, intwinds
= SCM_EOL
, ret
;
150 /* No need to reify if the continuation is never referenced in the handler. */
151 if (SCM_PROMPT_ESCAPE_P (prompt
))
154 dynwinds
= scm_i_dynwinds ();
155 while (!scm_is_eq (dynwinds
, extwinds
))
157 intwinds
= scm_cons (scm_car (dynwinds
), intwinds
);
158 dynwinds
= scm_cdr (dynwinds
);
161 flags
= SCM_F_VM_CONT_PARTIAL
;
162 if (cookie
>= 0 && SCM_PROMPT_REGISTERS (prompt
)->cookie
== cookie
)
163 flags
|= SCM_F_VM_CONT_REWINDABLE
;
165 /* Since non-escape continuations should begin with a thunk application, the
166 first bit of the stack should be a frame, with the saved fp equal to the fp
167 that was current when the prompt was made. */
168 if ((SCM
*)(SCM_PROMPT_REGISTERS (prompt
)->sp
[1])
169 != SCM_PROMPT_REGISTERS (prompt
)->fp
)
172 /* Capture from the top of the thunk application frame up to the end. Set an
173 MVRA only, as the post-abort code is in an MV context. */
174 vm_cont
= scm_i_vm_capture_stack (SCM_PROMPT_REGISTERS (prompt
)->sp
+ 4,
175 SCM_VM_DATA (vm
)->fp
,
176 SCM_VM_DATA (vm
)->sp
,
178 SCM_VM_DATA (vm
)->ip
,
181 ret
= scm_make_program (cont_objcode
,
182 scm_vector (scm_list_2 (vm_cont
, intwinds
)),
184 SCM_SET_CELL_WORD_0 (ret
,
185 SCM_CELL_WORD_0 (ret
) | SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION
);
190 scm_c_abort (SCM vm
, SCM tag
, size_t n
, SCM
*argv
, scm_t_int64 cookie
)
192 SCM cont
, winds
, prompt
= SCM_BOOL_F
;
196 /* Search the wind list for an appropriate prompt.
197 "Waiter, please bring us the wind list." */
198 for (winds
= scm_i_dynwinds (), delta
= 0;
200 winds
= SCM_CDR (winds
), delta
++)
202 SCM elt
= SCM_CAR (winds
);
203 if (SCM_PROMPT_P (elt
) && scm_is_eq (SCM_PROMPT_TAG (elt
), tag
))
210 /* If we didn't find anything, print a message and abort the process
211 right here. If you don't want this, establish a catch-all around
212 any code that might throw up. */
213 if (scm_is_false (prompt
))
215 if (scm_is_eq (tag
, scm_fluid_ref (scm_sys_default_prompt_tag
)))
217 fprintf (stderr
, "No prompt found for abort to default prompt tag!\n");
221 scm_misc_error ("abort", "abort to unknown tag", scm_list_1 (tag
));
224 cont
= reify_partial_continuation (vm
, prompt
, winds
, cookie
);
226 /* Unwind once more, beyond the prompt. */
227 winds
= SCM_CDR (winds
), delta
++;
230 scm_dowinds (winds
, delta
);
232 /* Restore VM regs */
233 SCM_VM_DATA (vm
)->fp
= SCM_PROMPT_REGISTERS (prompt
)->fp
;
234 SCM_VM_DATA (vm
)->sp
= SCM_PROMPT_REGISTERS (prompt
)->sp
;
235 SCM_VM_DATA (vm
)->ip
= SCM_PROMPT_REGISTERS (prompt
)->ip
;
237 /* Since we're jumping down, we should always have enough space */
238 if (SCM_VM_DATA (vm
)->sp
+ n
+ 1 >= SCM_VM_DATA (vm
)->stack_limit
)
242 *(++(SCM_VM_DATA (vm
)->sp
)) = cont
;
243 for (i
= 0; i
< n
; i
++)
244 *(++(SCM_VM_DATA (vm
)->sp
)) = argv
[i
];
245 *(++(SCM_VM_DATA (vm
)->sp
)) = scm_from_size_t (n
+1); /* +1 for continuation */
248 SCM_I_LONGJMP (SCM_PROMPT_REGISTERS (prompt
)->regs
, 1);
250 /* Shouldn't get here */
254 SCM_DEFINE (scm_at_abort
, "@abort", 2, 0, 0, (SCM tag
, SCM args
),
255 "Abort to the nearest prompt with tag @var{tag}.")
256 #define FUNC_NAME s_scm_at_abort
261 SCM_VALIDATE_LIST_COPYLEN (SCM_ARG2
, args
, n
);
262 argv
= alloca (sizeof (SCM
)*n
);
263 for (i
= 0; i
< n
; i
++, args
= scm_cdr (args
))
264 argv
[i
] = scm_car (args
);
266 scm_c_abort (scm_the_vm (), tag
, n
, argv
, -1);
268 /* Oh, what, you're still here? The abort must have been reinstated. Actually,
269 that's quite impossible, given that we're already in C-land here, so...
277 scm_i_prompt_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
279 scm_puts ("#<prompt ", port
);
280 scm_intprint (SCM_UNPACK (exp
), 16, port
);
281 scm_putc ('>', port
);
285 scm_init_control (void)
287 #include "libguile/control.x"
288 scm_sys_default_prompt_tag
= scm_make_fluid ();
289 scm_fluid_set_x (scm_sys_default_prompt_tag
, scm_gensym (SCM_UNDEFINED
));
290 scm_c_define ("%default-prompt-tag", scm_sys_default_prompt_tag
);