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);
45 ret
= scm_words (tag
, 5);
47 regs
= scm_gc_malloc_pointerless (sizeof (*regs
), "prompt registers");
51 regs
->cookie
= vm_cookie
;
53 SCM_SET_CELL_OBJECT (ret
, 1, k
);
54 SCM_SET_CELL_WORD (ret
, 2, (scm_t_bits
)regs
);
55 SCM_SET_CELL_OBJECT (ret
, 3, scm_i_dynwinds ());
60 /* Only to be called if the SCM_PROMPT_SETJMP returns 1 */
62 scm_i_prompt_pop_abort_args_x (SCM prompt
)
67 n
= scm_to_size_t (SCM_PROMPT_REGISTERS (prompt
)->sp
[0]);
68 for (i
= 0; i
< n
; i
++)
69 vals
= scm_cons (SCM_PROMPT_REGISTERS (prompt
)->sp
[-(i
+ 1)], vals
);
71 /* The abort did reset the VM's registers, but then these values
72 were pushed on; so we need to pop them ourselves. */
73 SCM_VM_DATA (scm_the_vm ())->sp
-= n
+ 1;
80 #ifdef WORDS_BIGENDIAN
81 #define OBJCODE_HEADER(main,meta) 0, 0, 0, main, 0, 0, 0, meta+8
82 #define META_HEADER(meta) 0, 0, 0, meta, 0, 0, 0, 0
84 #define OBJCODE_HEADER(main,meta) main, 0, 0, 0, meta+8, 0, 0, 0
85 #define META_HEADER(meta) meta, 0, 0, 0, 0, 0, 0, 0
88 #define ROUND_UP(len,align) (((len-1)|(align-1))+1)
89 #define ALIGN_PTR(type,p,align) (type*)(ROUND_UP (((scm_t_bits)p), align))
92 #define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym)\
93 static const type sym[]
94 #define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym)\
95 static SCM_ALIGNED (alignment) const type sym[]
97 #define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym)\
99 #define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym) \
100 SCM_SNARF_INIT(sym = scm_malloc (sizeof(sym##__unaligned) + alignment - 1); \
101 sym = ALIGN_PTR (type, sym, alignment); \
102 memcpy (sym, sym##__unaligned, sizeof(sym##__unaligned));) \
103 static type *sym = NULL; \
104 static const type sym##__unaligned[]
107 #define STATIC_OBJCODE_TAG \
108 SCM_PACK (scm_tc7_objcode | (SCM_F_OBJCODE_IS_STATIC << 8))
110 #define SCM_STATIC_OBJCODE(sym) \
111 SCM_DECLARE_STATIC_ALIGNED_ARRAY (scm_t_uint8, sym##__bytecode); \
112 SCM_STATIC_ALIGNED_ARRAY (8, scm_t_cell, sym##__cells) = { \
113 { STATIC_OBJCODE_TAG, SCM_PACK (sym##__bytecode) }, \
114 { SCM_BOOL_F, SCM_PACK (0) } \
116 static const SCM sym = SCM_PACK (sym##__cells); \
117 SCM_STATIC_ALIGNED_ARRAY (8, scm_t_uint8, sym##__bytecode)
120 SCM_STATIC_OBJCODE (cont_objcode
) = {
121 /* Like in continuations.c, but with partial-cont-call. */
122 OBJCODE_HEADER (8, 19),
123 /* leave args on the stack */
124 /* 0 */ scm_op_object_ref
, 0, /* push scm_vm_cont object */
125 /* 2 */ scm_op_object_ref
, 1, /* push internal winds */
126 /* 4 */ scm_op_partial_cont_call
, /* and go! */
127 /* 5 */ scm_op_nop
, scm_op_nop
, scm_op_nop
, /* pad to 8 bytes */
130 /* We could put some meta-info to say that this proc is a continuation. Not sure
131 how to do that, though. */
133 /* 0 */ scm_op_make_eol
, /* bindings */
134 /* 1 */ scm_op_make_eol
, /* sources */
135 /* 2 */ scm_op_make_int8
, 0, scm_op_make_int8
, 5, /* arity: from ip 0 to ip 7 */
136 /* 6 */ scm_op_make_int8_0
, /* the arity is 0 required args */
137 /* 7 */ scm_op_make_int8_0
, /* 0 optionals */
138 /* 8 */ scm_op_make_true
, /* and a rest arg */
139 /* 9 */ scm_op_list
, 0, 5, /* make a list of those 5 vals */
140 /* 12 */ scm_op_list
, 0, 1, /* and the arities will be a list of that one list */
141 /* 15 */ scm_op_list
, 0, 3, /* pack bindings, sources, and arities into list */
142 /* 18 */ scm_op_return
/* and return */
148 reify_partial_continuation (SCM vm
, SCM prompt
, SCM extwinds
,
151 SCM vm_cont
, dynwinds
, intwinds
= SCM_EOL
, ret
;
154 /* No need to reify if the continuation is never referenced in the handler. */
155 if (SCM_PROMPT_ESCAPE_P (prompt
))
158 dynwinds
= scm_i_dynwinds ();
159 while (!scm_is_eq (dynwinds
, extwinds
))
161 intwinds
= scm_cons (scm_car (dynwinds
), intwinds
);
162 dynwinds
= scm_cdr (dynwinds
);
165 flags
= SCM_F_VM_CONT_PARTIAL
;
166 if (cookie
>= 0 && SCM_PROMPT_REGISTERS (prompt
)->cookie
== cookie
)
167 flags
|= SCM_F_VM_CONT_REWINDABLE
;
169 /* Since non-escape continuations should begin with a thunk application, the
170 first bit of the stack should be a frame, with the saved fp equal to the fp
171 that was current when the prompt was made. */
172 if ((SCM
*)(SCM_PROMPT_REGISTERS (prompt
)->sp
[1])
173 != SCM_PROMPT_REGISTERS (prompt
)->fp
)
176 /* Capture from the top of the thunk application frame up to the end. Set an
177 MVRA only, as the post-abort code is in an MV context. */
178 vm_cont
= scm_i_vm_capture_stack (SCM_PROMPT_REGISTERS (prompt
)->sp
+ 4,
179 SCM_VM_DATA (vm
)->fp
,
180 SCM_VM_DATA (vm
)->sp
,
182 SCM_VM_DATA (vm
)->ip
,
185 ret
= scm_make_program (cont_objcode
,
186 scm_vector (scm_list_2 (vm_cont
, intwinds
)),
188 SCM_SET_CELL_WORD_0 (ret
,
189 SCM_CELL_WORD_0 (ret
) | SCM_F_PROGRAM_IS_CONTINUATION
);
194 scm_c_abort (SCM vm
, SCM tag
, size_t n
, SCM
*argv
, scm_t_int64 cookie
)
196 SCM cont
, winds
, prompt
= SCM_BOOL_F
;
200 /* Search the wind list for an appropriate prompt.
201 "Waiter, please bring us the wind list." */
202 for (winds
= scm_i_dynwinds (), delta
= 0;
204 winds
= SCM_CDR (winds
), delta
++)
206 SCM elt
= SCM_CAR (winds
);
207 if (SCM_PROMPT_P (elt
) && scm_is_eq (SCM_PROMPT_TAG (elt
), tag
))
214 /* If we didn't find anything, print a message and abort the process
215 right here. If you don't want this, establish a catch-all around
216 any code that might throw up. */
217 if (scm_is_false (prompt
))
219 if (scm_is_eq (tag
, scm_fluid_ref (scm_sys_default_prompt_tag
)))
221 fprintf (stderr
, "No prompt found for abort to default prompt tag!\n");
225 scm_misc_error ("abort", "abort to unknown tag", scm_list_1 (tag
));
228 cont
= reify_partial_continuation (vm
, prompt
, winds
, cookie
);
230 /* Unwind once more, beyond the prompt. */
231 winds
= SCM_CDR (winds
), delta
++;
234 scm_dowinds (winds
, delta
);
236 /* Restore VM regs */
237 SCM_VM_DATA (vm
)->fp
= SCM_PROMPT_REGISTERS (prompt
)->fp
;
238 SCM_VM_DATA (vm
)->sp
= SCM_PROMPT_REGISTERS (prompt
)->sp
;
239 SCM_VM_DATA (vm
)->ip
= SCM_PROMPT_REGISTERS (prompt
)->ip
;
241 /* Since we're jumping down, we should always have enough space */
242 if (SCM_VM_DATA (vm
)->sp
+ n
+ 1 >= SCM_VM_DATA (vm
)->stack_limit
)
246 *(++(SCM_VM_DATA (vm
)->sp
)) = cont
;
247 for (i
= 0; i
< n
; i
++)
248 *(++(SCM_VM_DATA (vm
)->sp
)) = argv
[i
];
249 *(++(SCM_VM_DATA (vm
)->sp
)) = scm_from_size_t (n
+1); /* +1 for continuation */
252 SCM_I_LONGJMP (SCM_PROMPT_REGISTERS (prompt
)->regs
, 1);
254 /* Shouldn't get here */
258 SCM_DEFINE (scm_at_abort
, "@abort", 2, 0, 0, (SCM tag
, SCM args
),
259 "Abort to the nearest prompt with tag @var{tag}.")
260 #define FUNC_NAME s_scm_at_abort
265 SCM_VALIDATE_LIST_COPYLEN (SCM_ARG2
, args
, n
);
266 argv
= alloca (sizeof (SCM
)*n
);
267 for (i
= 0; i
< n
; i
++, args
= scm_cdr (args
))
268 argv
[i
] = scm_car (args
);
270 scm_c_abort (scm_the_vm (), tag
, n
, argv
, -1);
272 /* Oh, what, you're still here? The abort must have been reinstated. Actually,
273 that's quite impossible, given that we're already in C-land here, so...
281 scm_init_control (void)
284 scm_sys_default_prompt_tag
= scm_make_fluid ();
285 scm_fluid_set_x (scm_sys_default_prompt_tag
, scm_gensym (SCM_UNDEFINED
));
286 scm_c_define ("%default-prompt-tag", scm_sys_default_prompt_tag
);