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 vm
, SCM k
, scm_t_uint8 escape_only_p
,
36 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");
48 regs
->fp
= SCM_VM_DATA (vm
)->fp
;
49 regs
->sp
= SCM_VM_DATA (vm
)->sp
;
50 regs
->ip
= SCM_VM_DATA (vm
)->ip
;
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 #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 ROUND_UP(len,align) (((len-1)|(align-1))+1)
69 #define ALIGN_PTR(type,p,align) (type*)(ROUND_UP (((scm_t_bits)p), align))
72 #define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym)\
73 static const type sym[]
74 #define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym)\
75 static SCM_ALIGNED (alignment) const type sym[]
77 #define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym)\
79 #define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym) \
80 SCM_SNARF_INIT(sym = scm_malloc (sizeof(sym##__unaligned) + alignment - 1); \
81 sym = ALIGN_PTR (type, sym, alignment); \
82 memcpy (sym, sym##__unaligned, sizeof(sym##__unaligned));) \
83 static type *sym = NULL; \
84 static const type sym##__unaligned[]
87 #define STATIC_OBJCODE_TAG \
88 SCM_PACK (scm_tc7_objcode | (SCM_F_OBJCODE_IS_STATIC << 8))
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 { STATIC_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)
100 SCM_STATIC_OBJCODE (cont_objcode
) = {
101 /* Like in continuations.c, but with partial-cont-call. */
102 OBJCODE_HEADER (8, 19),
103 /* leave args on the stack */
104 /* 0 */ scm_op_object_ref
, 0, /* push scm_vm_cont object */
105 /* 2 */ scm_op_object_ref
, 1, /* push internal winds */
106 /* 4 */ scm_op_partial_cont_call
, /* and go! */
107 /* 5 */ scm_op_nop
, scm_op_nop
, scm_op_nop
, /* pad to 8 bytes */
110 /* We could put some meta-info to say that this proc is a continuation. Not sure
111 how to do that, though. */
113 /* 0 */ scm_op_make_eol
, /* bindings */
114 /* 1 */ scm_op_make_eol
, /* sources */
115 /* 2 */ scm_op_make_int8
, 0, scm_op_make_int8
, 5, /* arity: from ip 0 to ip 7 */
116 /* 6 */ scm_op_make_int8_0
, /* the arity is 0 required args */
117 /* 7 */ scm_op_make_int8_0
, /* 0 optionals */
118 /* 8 */ scm_op_make_true
, /* and a rest arg */
119 /* 9 */ scm_op_list
, 0, 5, /* make a list of those 5 vals */
120 /* 12 */ scm_op_list
, 0, 1, /* and the arities will be a list of that one list */
121 /* 15 */ scm_op_list
, 0, 3, /* pack bindings, sources, and arities into list */
122 /* 18 */ scm_op_return
/* and return */
128 reify_partial_continuation (SCM vm
, SCM prompt
, SCM extwinds
,
131 SCM vm_cont
, dynwinds
, intwinds
= SCM_EOL
, ret
;
134 /* No need to reify if the continuation is never referenced in the handler. */
135 if (SCM_PROMPT_ESCAPE_P (prompt
))
138 dynwinds
= scm_i_dynwinds ();
139 while (!scm_is_eq (dynwinds
, extwinds
))
141 intwinds
= scm_cons (scm_car (dynwinds
), intwinds
);
142 dynwinds
= scm_cdr (dynwinds
);
145 flags
= SCM_F_VM_CONT_PARTIAL
;
146 if (cookie
>= 0 && SCM_PROMPT_REGISTERS (prompt
)->cookie
== cookie
)
147 flags
|= SCM_F_VM_CONT_REWINDABLE
;
149 /* Since non-escape continuations should begin with a thunk application, the
150 first bit of the stack should be a frame, with the saved fp equal to the fp
151 that was current when the prompt was made. */
152 if ((SCM
*)(SCM_PROMPT_REGISTERS (prompt
)->sp
[1])
153 != SCM_PROMPT_REGISTERS (prompt
)->fp
)
156 /* Capture from the top of the thunk application frame up to the end. Set an
157 MVRA only, as the post-abort code is in an MV context. */
158 vm_cont
= scm_i_vm_capture_stack (SCM_PROMPT_REGISTERS (prompt
)->sp
+ 4,
159 SCM_VM_DATA (vm
)->fp
,
160 SCM_VM_DATA (vm
)->sp
,
162 SCM_VM_DATA (vm
)->ip
,
165 ret
= scm_make_program (cont_objcode
,
166 scm_vector (scm_list_2 (vm_cont
, intwinds
)),
168 SCM_SET_CELL_WORD_0 (ret
,
169 SCM_CELL_WORD_0 (ret
) | SCM_F_PROGRAM_IS_CONTINUATION
);
174 scm_c_abort (SCM vm
, SCM tag
, size_t n
, SCM
*argv
, scm_t_int64 cookie
)
176 SCM cont
, winds
, prompt
= SCM_BOOL_F
;
180 /* Search the wind list for an appropriate prompt.
181 "Waiter, please bring us the wind list." */
182 for (winds
= scm_i_dynwinds (), delta
= 0;
184 winds
= SCM_CDR (winds
), delta
++)
186 SCM elt
= SCM_CAR (winds
);
187 if (SCM_PROMPT_P (elt
) && scm_is_eq (SCM_PROMPT_TAG (elt
), tag
))
194 /* If we didn't find anything, print a message and abort the process
195 right here. If you don't want this, establish a catch-all around
196 any code that might throw up. */
197 if (scm_is_false (prompt
))
199 if (scm_is_eq (tag
, scm_fluid_ref (scm_sys_default_prompt_tag
)))
201 fprintf (stderr
, "No prompt found for abort to default prompt tag!\n");
205 scm_misc_error ("abort", "abort to unknown tag", scm_list_1 (tag
));
208 cont
= reify_partial_continuation (vm
, prompt
, winds
, cookie
);
210 /* Unwind once more, beyond the prompt. */
211 winds
= SCM_CDR (winds
), delta
++;
214 scm_dowinds (winds
, delta
);
216 /* Restore VM regs */
217 SCM_VM_DATA (vm
)->fp
= SCM_PROMPT_REGISTERS (prompt
)->fp
;
218 SCM_VM_DATA (vm
)->sp
= SCM_PROMPT_REGISTERS (prompt
)->sp
;
219 SCM_VM_DATA (vm
)->ip
= SCM_PROMPT_REGISTERS (prompt
)->ip
;
221 /* Since we're jumping down, we should always have enough space */
222 if (SCM_VM_DATA (vm
)->sp
+ n
+ 1 >= SCM_VM_DATA (vm
)->stack_limit
)
226 *(++(SCM_VM_DATA (vm
)->sp
)) = cont
;
227 for (i
= 0; i
< n
; i
++)
228 *(++(SCM_VM_DATA (vm
)->sp
)) = argv
[i
];
229 *(++(SCM_VM_DATA (vm
)->sp
)) = scm_from_size_t (n
+1); /* +1 for continuation */
232 SCM_I_LONGJMP (SCM_PROMPT_REGISTERS (prompt
)->regs
, 1);
234 /* Shouldn't get here */
238 SCM_DEFINE (scm_at_abort
, "@abort", 2, 0, 0, (SCM tag
, SCM args
),
239 "Abort to the nearest prompt with tag @var{tag}.")
240 #define FUNC_NAME s_scm_at_abort
245 SCM_VALIDATE_LIST_COPYLEN (SCM_ARG2
, args
, n
);
246 argv
= alloca (sizeof (SCM
)*n
);
247 for (i
= 0; i
< n
; i
++, args
= scm_cdr (args
))
248 argv
[i
] = scm_car (args
);
250 scm_c_abort (scm_the_vm (), tag
, n
, argv
, -1);
252 /* Oh, what, you're still here? The abort must have been reinstated. Actually,
253 that's quite impossible, given that we're already in C-land here, so...
261 scm_init_control (void)
264 scm_sys_default_prompt_tag
= scm_make_fluid ();
265 scm_fluid_set_x (scm_sys_default_prompt_tag
, scm_gensym (SCM_UNDEFINED
));
266 scm_c_define ("%default-prompt-tag", scm_sys_default_prompt_tag
);