1 /* This file is a hodge-podge of various aspects of application and
2 continuations. It includes primitives like `call/cc' and
3 `procedure-arity', which have no better home, as well as parts of
4 closure compilation and wrappers for evaluation to handle stack
5 overflow and continuation-jump limits. */
6
7 #include "schpriv.h"
8 #include "schmach.h"
9 #include "schrktio.h"
10
ASSERT_SUSPEND_BREAK_ZERO()11 static void ASSERT_SUSPEND_BREAK_ZERO() {
12 #if 0
13 if (scheme_current_thread->suspend_break)
14 abort();
15 #endif
16 }
17
18 /* globals */
19 SHARED_OK int scheme_defining_primitives; /* set to 1 during start-up */
20
21 SHARED_OK int scheme_prim_opt_flags[(1 << SCHEME_PRIM_OPT_INDEX_SIZE)];
22
23 READ_ONLY Scheme_Object scheme_void[1]; /* the void constant */
24 READ_ONLY Scheme_Object *scheme_values_proc; /* the function bound to `values' */
25 READ_ONLY Scheme_Object *scheme_procedure_p_proc;
26 READ_ONLY Scheme_Object *scheme_procedure_arity_includes_proc;
27 READ_ONLY Scheme_Object *scheme_procedure_specialize_proc;
28 READ_ONLY Scheme_Object *scheme_void_proc;
29 READ_ONLY Scheme_Object *scheme_void_p_proc;
30 READ_ONLY Scheme_Object *scheme_check_not_undefined_proc;
31 READ_ONLY Scheme_Object *scheme_check_assign_not_undefined_proc;
32 READ_ONLY Scheme_Object *scheme_apply_proc;
33 READ_ONLY Scheme_Object *scheme_call_with_values_proc; /* the function bound to `call-with-values' */
34 READ_ONLY Scheme_Object *scheme_call_with_immed_mark_proc;
35 READ_ONLY Scheme_Object *scheme_reduced_procedure_struct;
36 READ_ONLY Scheme_Object *scheme_tail_call_waiting;
37 READ_ONLY Scheme_Object *scheme_default_prompt_tag;
38 READ_ONLY Scheme_Object *scheme_root_prompt_tag;
39 READ_ONLY Scheme_Object *scheme_chaperone_undefined_property;
40
41 /* READ ONLY SHARABLE GLOBALS */
42
43 ROSYM static Scheme_Object *certify_mode_symbol;
44 ROSYM static Scheme_Object *taint_mode_symbol;
45 ROSYM static Scheme_Object *transparent_symbol;
46 ROSYM static Scheme_Object *transparent_binding_symbol;
47 ROSYM static Scheme_Object *opaque_symbol;
48 ROSYM static Scheme_Object *none_symbol;
49 ROSYM static Scheme_Object *subprocesses_symbol;
50 ROSYM static Scheme_Object *is_method_symbol;
51 ROSYM static Scheme_Object *cont_key; /* uninterned */
52 ROSYM static Scheme_Object *barrier_prompt_key; /* uninterned */
53 ROSYM static Scheme_Object *prompt_cc_guard_key; /* uninterned */
54 ROSYM static Scheme_Object *mark_symbol;
55 READ_ONLY static Scheme_Prompt *original_default_prompt; /* for escapes, represents the implicit initial prompt */
56 READ_ONLY static Scheme_Object *call_with_prompt_proc;
57 READ_ONLY static Scheme_Object *abort_continuation_proc;
58 READ_ONLY static Scheme_Object *internal_call_cc_prim;
59 READ_ONLY static Scheme_Object *finish_call_cc_prim;
60 READ_ONLY static Scheme_Object *propagate_abort_prim;
61
62 /* Caches need to be thread-local: */
63 THREAD_LOCAL_DECL(static Scheme_Prompt *available_prompt);
64 THREAD_LOCAL_DECL(static Scheme_Prompt *available_cws_prompt);
65 THREAD_LOCAL_DECL(static Scheme_Prompt *available_regular_prompt);
66 THREAD_LOCAL_DECL(static Scheme_Dynamic_Wind *available_prompt_dw);
67 THREAD_LOCAL_DECL(static Scheme_Meta_Continuation *available_prompt_mc);
68 THREAD_LOCAL_DECL(static Scheme_Cont *offstack_cont);
69 THREAD_LOCAL_DECL(static Scheme_Overflow *offstack_overflow);
70
71 THREAD_LOCAL_DECL(int scheme_cont_capture_count);
72 THREAD_LOCAL_DECL(static int scheme_prompt_capture_count);
73
74 #define MARK_CACHE_THRESHOLD 16
75
76 /* locals */
77 static Scheme_Object *procedure_p (int argc, Scheme_Object *argv[]);
78 static Scheme_Object *apply (int argc, Scheme_Object *argv[]);
79 static Scheme_Object *map (int argc, Scheme_Object *argv[]);
80 static Scheme_Object *for_each (int argc, Scheme_Object *argv[]);
81 static Scheme_Object *andmap (int argc, Scheme_Object *argv[]);
82 static Scheme_Object *ormap (int argc, Scheme_Object *argv[]);
83 static Scheme_Object *call_cc (int argc, Scheme_Object *argv[]);
84 static Scheme_Object *internal_call_cc (int argc, Scheme_Object *argv[]);
85 static Scheme_Object *finish_call_cc (int argc, Scheme_Object *argv[]);
86 static Scheme_Object *call_in_continuation (int argc, Scheme_Object *argv[]);
87 static Scheme_Object *propagate_abort (int argc, Scheme_Object *argv[]);
88 static Scheme_Object *continuation_p (int argc, Scheme_Object *argv[]);
89 static Scheme_Object *call_with_continuation_barrier (int argc, Scheme_Object *argv[]);
90 static Scheme_Object *call_with_prompt (int argc, Scheme_Object *argv[]);
91 static Scheme_Object *call_with_control (int argc, Scheme_Object *argv[]);
92 static Scheme_Object *make_prompt_tag (int argc, Scheme_Object *argv[]);
93 static Scheme_Object *abort_continuation (int argc, Scheme_Object *argv[]);
94 static Scheme_Object *continuation_prompt_available(int argc, Scheme_Object *argv[]);
95 static Scheme_Object *get_default_prompt_tag (int argc, Scheme_Object *argv[]);
96 static Scheme_Object *prompt_tag_p (int argc, Scheme_Object *argv[]);
97 static Scheme_Object *impersonate_prompt_tag (int argc, Scheme_Object *argv[]);
98 static Scheme_Object *chaperone_prompt_tag (int argc, Scheme_Object *argv[]);
99 static Scheme_Object *call_with_sema (int argc, Scheme_Object *argv[]);
100 static Scheme_Object *call_with_sema_enable_break (int argc, Scheme_Object *argv[]);
101 static Scheme_Object *make_continuation_mark_key (int argc, Scheme_Object *argv[]);
102 static Scheme_Object *continuation_mark_key_p (int argc, Scheme_Object *argv[]);
103 static Scheme_Object *impersonate_continuation_mark_key (int argc, Scheme_Object *argv[]);
104 static Scheme_Object *chaperone_continuation_mark_key (int argc, Scheme_Object *argv[]);
105 static Scheme_Object *cc_marks (int argc, Scheme_Object *argv[]);
106 static Scheme_Object *cont_marks (int argc, Scheme_Object *argv[]);
107 static Scheme_Object *cc_marks_p (int argc, Scheme_Object *argv[]);
108 static Scheme_Object *extract_cc_marks (int argc, Scheme_Object *argv[]);
109 static Scheme_Object *extract_cc_markses (int argc, Scheme_Object *argv[]);
110 static Scheme_Object *extract_cc_iterator (int argc, Scheme_Object *argv[]);
111 static Scheme_Object *extract_cc_proc_marks (int argc, Scheme_Object *argv[]);
112 static Scheme_Object *extract_one_cc_mark (int argc, Scheme_Object *argv[]);
113 static Scheme_Object *call_with_immediate_cc_mark (int argc, Scheme_Object *argv[]);
114 static Scheme_Object *void_func (int argc, Scheme_Object *argv[]);
115 static Scheme_Object *void_p (int argc, Scheme_Object *argv[]);
116 static Scheme_Object *dynamic_wind (int argc, Scheme_Object *argv[]);
117 static Scheme_Object *time_apply(int argc, Scheme_Object *argv[]);
118 static Scheme_Object *current_milliseconds(int argc, Scheme_Object **argv);
119 static Scheme_Object *current_inexact_milliseconds(int argc, Scheme_Object **argv);
120 static Scheme_Object *current_inexact_monotonic_milliseconds(int argc, Scheme_Object **argv);
121 static Scheme_Object *current_process_milliseconds(int argc, Scheme_Object **argv);
122 static Scheme_Object *current_gc_milliseconds(int argc, Scheme_Object **argv);
123 static Scheme_Object *current_seconds(int argc, Scheme_Object **argv);
124 static Scheme_Object *seconds_to_date(int argc, Scheme_Object **argv);
125 static Scheme_Object *object_name(int argc, Scheme_Object *argv[]);
126 static Scheme_Object *procedure_arity(int argc, Scheme_Object *argv[]);
127 static Scheme_Object *procedure_arity_p(int argc, Scheme_Object *argv[]);
128 static Scheme_Object *procedure_arity_mask(int argc, Scheme_Object *argv[]);
129 static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[]);
130 static Scheme_Object *procedure_reduce_arity_mask(int argc, Scheme_Object *argv[]);
131 static Scheme_Object *procedure_rename(int argc, Scheme_Object *argv[]);
132 static Scheme_Object *procedure_to_method(int argc, Scheme_Object *argv[]);
133 static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[]);
134 static Scheme_Object *procedure_specialize(int argc, Scheme_Object *argv[]);
135 static Scheme_Object *chaperone_procedure(int argc, Scheme_Object *argv[]);
136 static Scheme_Object *unsafe_chaperone_procedure(int argc, Scheme_Object *argv[]);
137 static Scheme_Object *impersonate_procedure(int argc, Scheme_Object *argv[]);
138 static Scheme_Object *unsafe_impersonate_procedure(int argc, Scheme_Object *argv[]);
139 static Scheme_Object *chaperone_procedure_star(int argc, Scheme_Object *argv[]);
140 static Scheme_Object *impersonate_procedure_star(int argc, Scheme_Object *argv[]);
141 static Scheme_Object *primitive_p(int argc, Scheme_Object *argv[]);
142 static Scheme_Object *primitive_closure_p(int argc, Scheme_Object *argv[]);
143 static Scheme_Object *primitive_result_arity (int argc, Scheme_Object *argv[]);
144 static Scheme_Object *procedure_result_arity (int argc, Scheme_Object *argv[]);
145 static Scheme_Object *call_with_values(int argc, Scheme_Object *argv[]);
146 Scheme_Object *scheme_values(int argc, Scheme_Object *argv[]);
147 static Scheme_Object *current_print(int argc, Scheme_Object **argv);
148 static Scheme_Object *current_prompt_read(int, Scheme_Object **);
149 static Scheme_Object *current_read(int, Scheme_Object **);
150 static Scheme_Object *current_get_read_input_port(int, Scheme_Object **);
151
152 static Scheme_Object *chaperone_wrap_cc_guard(Scheme_Object *obj, Scheme_Object *proc);
153 static Scheme_Object *do_cc_guard(Scheme_Object *v, Scheme_Object *cc_guard, Scheme_Object *chaperone);
154
155 static Scheme_Object *chaperone_unsafe_undefined(int argc, Scheme_Object **argv);
156
157 static Scheme_Object *unsafe_abort_continuation_no_dws(int argc, Scheme_Object *argv[]);
158 static Scheme_Object *unsafe_call_with_control_no_dws(int argc, Scheme_Object *argv[]);
159 static Scheme_Object *unsafe_root_continuation_prompt_tag(int argc, Scheme_Object *argv[]);
160
161 static Scheme_Object *
162 scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set, Scheme_Object *key,
163 Scheme_Object *prompt_tag, Scheme_Meta_Continuation **_meta,
164 MZ_MARK_POS_TYPE *_vpos);
165 static Scheme_Object *get_set_cont_mark_by_pos(Scheme_Object *key,
166 Scheme_Thread *p,
167 Scheme_Meta_Continuation *mc,
168 MZ_MARK_POS_TYPE mpos,
169 Scheme_Object *val);
170 static Scheme_Cont_Mark_Chain *current_mark_chain(const char *who, Scheme_Object *prompt_tag);
171
172 static Scheme_Object *jump_to_alt_continuation();
173 static void reset_cjs(Scheme_Continuation_Jump_State *a);
174
175 typedef void (*DW_PrePost_Proc)(void *);
176
177 #define CONS(a,b) scheme_make_pair(a,b)
178
179 static Scheme_Object *mask_to_arity(Scheme_Object *mask, int mode);
180
181 #ifdef MZ_PRECISE_GC
182 static void register_traversers(void);
183 #endif
184
185 /* See call_cc: */
186 typedef struct Scheme_Dynamic_Wind_List {
187 MZTAG_IF_REQUIRED
188 Scheme_Dynamic_Wind *dw;
189 int meta_depth;
190 struct Scheme_Dynamic_Wind_List *next;
191 } Scheme_Dynamic_Wind_List;
192
193 /*========================================================================*/
194 /* initialization */
195 /*========================================================================*/
196
197 void
scheme_init_fun(Scheme_Startup_Env * env)198 scheme_init_fun (Scheme_Startup_Env *env)
199 {
200 Scheme_Object *o;
201
202 #ifdef MZ_PRECISE_GC
203 register_traversers();
204 #endif
205
206 #ifdef MZ_APPLY_WAITING_CONSTANT
207 scheme_tail_call_waiting = MZ_APPLY_WAITING_CONSTANT;
208 #else
209 REGISTER_SO(scheme_tail_call_waiting);
210 scheme_tail_call_waiting = scheme_alloc_eternal_object();
211 scheme_tail_call_waiting->type = scheme_tail_call_waiting_type;
212 #endif
213
214 REGISTER_SO(scheme_procedure_p_proc);
215 REGISTER_SO(scheme_procedure_arity_includes_proc);
216
217 o = scheme_make_folding_prim(procedure_p, "procedure?", 1, 1, 1);
218 SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
219 | SCHEME_PRIM_IS_OMITABLE
220 | SCHEME_PRIM_PRODUCES_BOOL);
221 scheme_addto_prim_instance("procedure?", o, env);
222
223 scheme_procedure_p_proc = o;
224
225 REGISTER_SO(scheme_apply_proc);
226 scheme_apply_proc = scheme_make_prim_w_arity2(apply,
227 "apply",
228 2, -1,
229 0, -1);
230 scheme_addto_prim_instance("apply", scheme_apply_proc, env);
231
232 o = scheme_make_noncm_prim(map, "map", 2, -1);
233 SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT);
234 scheme_addto_prim_instance("map", o, env);
235
236 o = scheme_make_noncm_prim(for_each, "for-each", 2, -1);
237 SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT);
238 scheme_addto_prim_instance("for-each", o, env);
239
240 o = scheme_make_prim_w_arity(andmap, "andmap", 2, -1);
241 SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT);
242 scheme_addto_prim_instance("andmap", o, env);
243
244 o = scheme_make_prim_w_arity(ormap, "ormap", 2, -1);
245 SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT);
246 scheme_addto_prim_instance("ormap", o, env);
247
248 REGISTER_SO(scheme_call_with_values_proc);
249 scheme_call_with_values_proc = scheme_make_prim_w_arity2(call_with_values,
250 "call-with-values",
251 2, 2,
252 0, -1);
253 scheme_addto_prim_instance("call-with-values",
254 scheme_call_with_values_proc,
255 env);
256
257 REGISTER_SO(scheme_values_proc);
258 scheme_values_proc = scheme_make_prim_w_arity2(scheme_values,
259 "values",
260 0, -1,
261 0, -1);
262 SCHEME_PRIM_PROC_FLAGS(scheme_values_proc) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
263 | SCHEME_PRIM_IS_BINARY_INLINED
264 | SCHEME_PRIM_IS_NARY_INLINED
265 | SCHEME_PRIM_IS_OMITABLE);
266 scheme_addto_prim_instance("values",
267 scheme_values_proc,
268 env);
269
270 o = scheme_make_prim_w_arity2(scheme_call_ec,
271 "call-with-escape-continuation",
272 1, 1,
273 0, -1);
274 scheme_addto_prim_instance("call-with-escape-continuation", o, env);
275
276 REGISTER_SO(internal_call_cc_prim);
277 internal_call_cc_prim = scheme_make_prim_w_arity2(internal_call_cc,
278 "call-with-current-continuation",
279 1, 3,
280 0, -1);
281 REGISTER_SO(finish_call_cc_prim);
282 finish_call_cc_prim = scheme_make_prim_w_arity2(finish_call_cc,
283 "finish-call-with-current-continuation",
284 2, 2,
285 0, -1);
286 REGISTER_SO(propagate_abort_prim);
287 propagate_abort_prim = scheme_make_prim_w_arity(propagate_abort, "propagate-abort", 0, -1);
288
289 # define MAX_CALL_CC_ARG_COUNT 2
290 o = scheme_make_prim_w_arity2(call_cc,
291 "call-with-current-continuation",
292 1, MAX_CALL_CC_ARG_COUNT,
293 0, -1);
294
295 scheme_addto_prim_instance("call-with-current-continuation", o, env);
296
297 scheme_addto_prim_instance("call-with-composable-continuation",
298 scheme_make_prim_w_arity2(call_with_control,
299 "call-with-composable-continuation",
300 1, 2,
301 0, -1),
302 env);
303
304 scheme_addto_prim_instance("continuation?",
305 scheme_make_folding_prim(continuation_p,
306 "continuation?",
307 1, 1, 1),
308 env);
309
310 scheme_addto_prim_instance("call-with-continuation-barrier",
311 scheme_make_prim_w_arity2(call_with_continuation_barrier,
312 "call-with-continuation-barrier",
313 1, 1,
314 0, -1),
315 env);
316
317 REGISTER_SO(call_with_prompt_proc);
318 call_with_prompt_proc = scheme_make_prim_w_arity2(call_with_prompt,
319 "call-with-continuation-prompt",
320 1, -1,
321 0, -1);
322 scheme_addto_prim_instance("call-with-continuation-prompt",
323 call_with_prompt_proc,
324 env);
325
326 scheme_addto_prim_instance("call-in-continuation",
327 scheme_make_prim_w_arity2(call_in_continuation,
328 "call-in-continuation",
329 2, 2,
330 0, -1),
331 env);
332
333 REGISTER_SO(abort_continuation_proc);
334 abort_continuation_proc = scheme_make_prim_w_arity(abort_continuation,
335 "abort-current-continuation",
336 1, -1);
337 scheme_addto_prim_instance("abort-current-continuation",
338 abort_continuation_proc,
339 env);
340
341 scheme_addto_prim_instance("continuation-prompt-available?",
342 scheme_make_prim_w_arity(continuation_prompt_available,
343 "continuation-prompt-available?",
344 1, 2),
345 env);
346
347 scheme_addto_prim_instance("make-continuation-prompt-tag",
348 scheme_make_prim_w_arity(make_prompt_tag,
349 "make-continuation-prompt-tag",
350 0, 1),
351 env);
352
353 scheme_addto_prim_instance("default-continuation-prompt-tag",
354 scheme_make_prim_w_arity(get_default_prompt_tag,
355 "default-continuation-prompt-tag",
356 0, 0),
357 env);
358 scheme_addto_prim_instance("continuation-prompt-tag?",
359 scheme_make_folding_prim(prompt_tag_p,
360 "continuation-prompt-tag?",
361 1, 1, 1),
362 env);
363 scheme_addto_prim_instance("impersonate-prompt-tag",
364 scheme_make_prim_w_arity(impersonate_prompt_tag,
365 "impersonate-prompt-tag",
366 3, -1),
367 env);
368 scheme_addto_prim_instance("chaperone-prompt-tag",
369 scheme_make_prim_w_arity(chaperone_prompt_tag,
370 "chaperone-prompt-tag",
371 3, -1),
372 env);
373
374 scheme_addto_prim_instance("call-with-semaphore",
375 scheme_make_prim_w_arity2(call_with_sema,
376 "call-with-semaphore",
377 2, -1,
378 0, -1),
379 env);
380 scheme_addto_prim_instance("call-with-semaphore/enable-break",
381 scheme_make_prim_w_arity2(call_with_sema_enable_break,
382 "call-with-semaphore/enable-break",
383 2, -1,
384 0, -1),
385 env);
386
387 scheme_addto_prim_instance("make-continuation-mark-key",
388 scheme_make_prim_w_arity(make_continuation_mark_key,
389 "make-continuation-mark-key",
390 0, 1),
391 env);
392 scheme_addto_prim_instance("continuation-mark-key?",
393 scheme_make_prim_w_arity(continuation_mark_key_p,
394 "continuation-mark-key?",
395 1, 1),
396 env);
397 scheme_addto_prim_instance("impersonate-continuation-mark-key",
398 scheme_make_prim_w_arity(impersonate_continuation_mark_key,
399 "impersonate-continuation-mark-key",
400 3, -1),
401 env);
402 scheme_addto_prim_instance("chaperone-continuation-mark-key",
403 scheme_make_prim_w_arity(chaperone_continuation_mark_key,
404 "chaperone-continuation-mark-key",
405 3, -1),
406 env);
407
408 scheme_addto_prim_instance("current-continuation-marks",
409 scheme_make_prim_w_arity(cc_marks,
410 "current-continuation-marks",
411 0, 1),
412 env);
413 scheme_addto_prim_instance("continuation-marks",
414 scheme_make_prim_w_arity(cont_marks,
415 "continuation-marks",
416 1, 2),
417 env);
418 scheme_addto_prim_instance("continuation-mark-set->list",
419 scheme_make_prim_w_arity(extract_cc_marks,
420 "continuation-mark-set->list",
421 2, 3),
422 env);
423 scheme_addto_prim_instance("continuation-mark-set->list*",
424 scheme_make_prim_w_arity(extract_cc_markses,
425 "continuation-mark-set->list*",
426 2, 4),
427 env);
428
429 scheme_addto_prim_instance("continuation-mark-set->iterator",
430 scheme_make_prim_w_arity(extract_cc_iterator,
431 "continuation-mark-set->iterator",
432 2, 4),
433 env);
434
435 o = scheme_make_prim_w_arity(extract_one_cc_mark,
436 "continuation-mark-set-first",
437 2, 4);
438 SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED);
439 scheme_addto_prim_instance("continuation-mark-set-first", o, env);
440
441 REGISTER_SO(scheme_call_with_immed_mark_proc);
442 scheme_call_with_immed_mark_proc = scheme_make_prim_w_arity2(call_with_immediate_cc_mark,
443 "call-with-immediate-continuation-mark",
444 2, 3,
445 0, -1);
446 scheme_addto_prim_instance("call-with-immediate-continuation-mark",
447 scheme_call_with_immed_mark_proc,
448 env);
449 scheme_addto_prim_instance("continuation-mark-set?",
450 scheme_make_prim_w_arity(cc_marks_p,
451 "continuation-mark-set?",
452 1, 1),
453 env);
454 scheme_addto_prim_instance("continuation-mark-set->context",
455 scheme_make_prim_w_arity(extract_cc_proc_marks,
456 "continuation-mark-set->context",
457 1, 1),
458 env);
459
460 REGISTER_SO(scheme_void_proc);
461 scheme_void_proc = scheme_make_folding_prim(void_func,
462 "void",
463 0, -1, 1);
464 SCHEME_PRIM_PROC_FLAGS(scheme_void_proc) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE);
465 scheme_addto_prim_instance("void", scheme_void_proc, env);
466
467
468 REGISTER_SO(scheme_void_p_proc);
469 scheme_void_p_proc = scheme_make_folding_prim(void_p, "void?", 1, 1, 1);
470 SCHEME_PRIM_PROC_FLAGS(scheme_void_p_proc) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
471 | SCHEME_PRIM_IS_OMITABLE
472 | SCHEME_PRIM_PRODUCES_BOOL);
473 scheme_addto_prim_instance("void?", scheme_void_p_proc, env);
474
475 scheme_addto_prim_instance("time-apply",
476 scheme_make_prim_w_arity2(time_apply,
477 "time-apply",
478 2, 2,
479 4, 4),
480 env);
481 scheme_addto_prim_instance("current-milliseconds",
482 scheme_make_immed_prim(current_milliseconds,
483 "current-milliseconds",
484 0, 0),
485 env);
486 scheme_addto_prim_instance("current-inexact-milliseconds",
487 scheme_make_immed_prim(current_inexact_milliseconds,
488 "current-inexact-milliseconds",
489 0, 0),
490 env);
491 scheme_addto_prim_instance("current-inexact-monotonic-milliseconds",
492 scheme_make_immed_prim(current_inexact_monotonic_milliseconds,
493 "current-inexact-monotonic-milliseconds",
494 0, 0),
495 env);
496 scheme_addto_prim_instance("current-process-milliseconds",
497 scheme_make_immed_prim(current_process_milliseconds,
498 "current-process-milliseconds",
499 0, 1),
500 env);
501 scheme_addto_prim_instance("current-gc-milliseconds",
502 scheme_make_immed_prim(current_gc_milliseconds,
503 "current-gc-milliseconds",
504 0, 0),
505 env);
506 scheme_addto_prim_instance("current-seconds",
507 scheme_make_immed_prim(current_seconds,
508 "current-seconds",
509 0, 0),
510 env);
511 scheme_addto_prim_instance("seconds->date",
512 scheme_make_immed_prim(seconds_to_date,
513 "seconds->date",
514 1, 2),
515 env);
516
517 scheme_addto_prim_instance("dynamic-wind",
518 scheme_make_prim_w_arity(dynamic_wind,
519 "dynamic-wind",
520 3, 3),
521 env);
522
523 scheme_addto_prim_instance("object-name",
524 scheme_make_folding_prim(object_name,
525 "object-name",
526 1, 1, 1),
527 env);
528
529 scheme_addto_prim_instance("procedure-arity",
530 scheme_make_folding_prim(procedure_arity,
531 "procedure-arity",
532 1, 1, 1),
533 env);
534 scheme_addto_prim_instance("procedure-arity?",
535 scheme_make_folding_prim(procedure_arity_p,
536 "procedure-arity?",
537 1, 1, 1),
538 env);
539
540 o = scheme_make_folding_prim(scheme_procedure_arity_includes,
541 "procedure-arity-includes?",
542 2, 3, 1);
543 SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
544 | SCHEME_PRIM_AD_HOC_OPT
545 | SCHEME_PRIM_PRODUCES_BOOL);
546 scheme_procedure_arity_includes_proc = o;
547 scheme_addto_prim_instance("procedure-arity-includes?", o, env);
548
549 scheme_addto_prim_instance("procedure-arity-mask",
550 scheme_make_folding_prim(procedure_arity_mask,
551 "procedure-arity-mask",
552 1, 1, 1),
553 env);
554
555 scheme_addto_prim_instance("procedure-reduce-arity",
556 scheme_make_prim_w_arity(procedure_reduce_arity,
557 "procedure-reduce-arity",
558 2, 3),
559 env);
560 scheme_addto_prim_instance("procedure-rename",
561 scheme_make_prim_w_arity(procedure_rename,
562 "procedure-rename",
563 2, 2),
564 env);
565 scheme_addto_prim_instance("procedure-reduce-arity-mask",
566 scheme_make_prim_w_arity(procedure_reduce_arity_mask,
567 "procedure-reduce-arity-mask",
568 2, 3),
569 env);
570 scheme_addto_prim_instance("procedure->method",
571 scheme_make_prim_w_arity(procedure_to_method,
572 "procedure->method",
573 1, 1),
574 env);
575
576 o = scheme_make_folding_prim(procedure_equal_closure_p,
577 "procedure-closure-contents-eq?",
578 2, 2, 1);
579 SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT
580 | SCHEME_PRIM_PRODUCES_BOOL);
581 scheme_addto_prim_instance("procedure-closure-contents-eq?", o, env);
582
583 REGISTER_SO(scheme_procedure_specialize_proc);
584 o = scheme_make_prim_w_arity(procedure_specialize,
585 "procedure-specialize",
586 1, 1);
587 scheme_procedure_specialize_proc = o;
588 scheme_addto_prim_instance("procedure-specialize", o, env);
589
590 scheme_addto_prim_instance("chaperone-procedure",
591 scheme_make_prim_w_arity(chaperone_procedure,
592 "chaperone-procedure",
593 2, -1),
594 env);
595 scheme_addto_prim_instance("impersonate-procedure",
596 scheme_make_prim_w_arity(impersonate_procedure,
597 "impersonate-procedure",
598 2, -1),
599 env);
600 scheme_addto_prim_instance("chaperone-procedure*",
601 scheme_make_prim_w_arity(chaperone_procedure_star,
602 "chaperone-procedure*",
603 2, -1),
604 env);
605 scheme_addto_prim_instance("impersonate-procedure*",
606 scheme_make_prim_w_arity(impersonate_procedure_star,
607 "impersonate-procedure*",
608 2, -1),
609 env);
610
611 scheme_addto_prim_instance("primitive?",
612 scheme_make_folding_prim(primitive_p,
613 "primitive?",
614 1, 1, 1),
615 env);
616 scheme_addto_prim_instance("primitive-closure?",
617 scheme_make_folding_prim(primitive_closure_p,
618 "primitive-closure?",
619 1, 1, 1),
620 env);
621
622 scheme_addto_prim_instance("primitive-result-arity",
623 scheme_make_folding_prim(primitive_result_arity,
624 "primitive-result-arity",
625 1, 1, 1),
626 env);
627
628 scheme_addto_prim_instance("procedure-result-arity",
629 scheme_make_folding_prim(procedure_result_arity,
630 "procedure-result-arity",
631 1, 1, 1),
632 env);
633
634 scheme_addto_prim_instance("current-print",
635 scheme_register_parameter(current_print,
636 "current-print",
637 MZCONFIG_PRINT_HANDLER),
638 env);
639 scheme_addto_prim_instance("current-prompt-read",
640 scheme_register_parameter(current_prompt_read,
641 "current-prompt-read",
642 MZCONFIG_PROMPT_READ_HANDLER),
643 env);
644 scheme_addto_prim_instance("current-read-interaction",
645 scheme_register_parameter(current_read,
646 "current-read-interaction",
647 MZCONFIG_READ_HANDLER),
648 env);
649 scheme_addto_prim_instance("current-get-interaction-input-port",
650 scheme_register_parameter(current_get_read_input_port,
651 "current-get-interaction-input-port",
652 MZCONFIG_READ_INPUT_PORT_HANDLER),
653 env);
654
655 REGISTER_SO(certify_mode_symbol);
656 REGISTER_SO(taint_mode_symbol);
657 REGISTER_SO(transparent_symbol);
658 REGISTER_SO(transparent_binding_symbol);
659 REGISTER_SO(opaque_symbol);
660 REGISTER_SO(none_symbol);
661 certify_mode_symbol = scheme_intern_symbol("certify-mode");
662 taint_mode_symbol = scheme_intern_symbol("taint-mode");
663 transparent_symbol = scheme_intern_symbol("transparent");
664 transparent_binding_symbol = scheme_intern_symbol("transparent-binding");
665 opaque_symbol = scheme_intern_symbol("opaque");
666 none_symbol = scheme_intern_symbol("none");
667
668 REGISTER_SO(subprocesses_symbol);
669 subprocesses_symbol = scheme_intern_symbol("subprocesses");
670
671 REGISTER_SO(is_method_symbol);
672 REGISTER_SO(cont_key);
673 REGISTER_SO(barrier_prompt_key);
674 REGISTER_SO(prompt_cc_guard_key);
675 is_method_symbol = scheme_intern_symbol("method-arity-error");
676 cont_key = scheme_make_symbol("k"); /* uninterned */
677 barrier_prompt_key = scheme_make_symbol("bar"); /* uninterned */
678 prompt_cc_guard_key = scheme_make_symbol("cc"); /* uninterned */
679
680 REGISTER_SO(mark_symbol);
681 mark_symbol = scheme_intern_symbol("mark");
682
683 REGISTER_SO(scheme_default_prompt_tag);
684 {
685 Scheme_Object *a[1];
686 a[0] = scheme_intern_symbol("default");
687 scheme_default_prompt_tag = make_prompt_tag(1, a);
688 (void)scheme_hash_key(SCHEME_PTR_VAL(scheme_default_prompt_tag));
689 }
690
691 REGISTER_SO(scheme_root_prompt_tag);
692 {
693 Scheme_Object *a[1];
694 a[0] = scheme_intern_symbol("root");
695 scheme_root_prompt_tag = make_prompt_tag(1, a);
696 (void)scheme_hash_key(SCHEME_PTR_VAL(scheme_root_prompt_tag));
697 }
698
699 REGISTER_SO(original_default_prompt);
700 original_default_prompt = MALLOC_ONE_TAGGED(Scheme_Prompt);
701 original_default_prompt->so.type = scheme_prompt_type;
702 original_default_prompt->tag = scheme_default_prompt_tag;
703 }
704
705 void
scheme_init_unsafe_fun(Scheme_Startup_Env * env)706 scheme_init_unsafe_fun (Scheme_Startup_Env *env)
707 {
708 Scheme_Object *o;
709
710 REGISTER_SO(scheme_check_not_undefined_proc);
711 o = scheme_make_prim_w_arity(scheme_check_not_undefined, "check-not-unsafe-undefined", 2, 2);
712 scheme_check_not_undefined_proc = o;
713 SCHEME_PRIM_PROC_FLAGS(o) |= (SCHEME_PRIM_OPT_IMMEDIATE
714 | scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED));
715 scheme_addto_prim_instance("check-not-unsafe-undefined", o, env);
716
717 REGISTER_SO(scheme_check_assign_not_undefined_proc);
718 o = scheme_make_prim_w_arity(scheme_check_assign_not_undefined, "check-not-unsafe-undefined/assign", 2, 2);
719 scheme_check_assign_not_undefined_proc = o;
720 SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED);
721 scheme_addto_prim_instance("check-not-unsafe-undefined/assign", o, env);
722
723 scheme_addto_prim_instance("unsafe-undefined", scheme_undefined, env);
724
725 REGISTER_SO(scheme_chaperone_undefined_property);
726 o = scheme_make_struct_type_property(scheme_intern_symbol("chaperone-unsafe-undefined"));
727 scheme_chaperone_undefined_property = o;
728 scheme_addto_prim_instance("prop:chaperone-unsafe-undefined", o, env);
729
730 o = scheme_make_prim_w_arity(chaperone_unsafe_undefined, "chaperone-struct-unsafe-undefined", 1, 1);
731 scheme_addto_prim_instance("chaperone-struct-unsafe-undefined", o, env);
732
733 scheme_addto_prim_instance("unsafe-chaperone-procedure",
734 scheme_make_prim_w_arity(unsafe_chaperone_procedure,
735 "unsafe-chaperone-procedure",
736 2, -1),
737 env);
738 scheme_addto_prim_instance("unsafe-impersonate-procedure",
739 scheme_make_prim_w_arity(unsafe_impersonate_procedure,
740 "unsafe-impersonate-procedure",
741 2, -1),
742 env);
743
744 ADD_PRIM_W_ARITY("unsafe-abort-current-continuation/no-wind", unsafe_abort_continuation_no_dws, 2, 2, env);
745 ADD_PRIM_W_ARITY("unsafe-call-with-composable-continuation/no-wind", unsafe_call_with_control_no_dws, 2, 2, env);
746
747 ADD_PRIM_W_ARITY("unsafe-root-continuation-prompt-tag", unsafe_root_continuation_prompt_tag, 0, 0, env);
748 }
749
750 void
scheme_init_fun_places()751 scheme_init_fun_places()
752 {
753 REGISTER_SO(offstack_cont);
754 REGISTER_SO(offstack_overflow);
755 }
756
757
758 Scheme_Object *
scheme_make_void(void)759 scheme_make_void (void)
760 {
761 return scheme_void;
762 }
763
764 /*========================================================================*/
765 /* primitive procedures */
766 /*========================================================================*/
767
768 static Scheme_Object *
make_prim_closure(Scheme_Prim * fun,int eternal,const char * name,mzshort mina,mzshort maxa,int flags,mzshort minr,mzshort maxr,int closed,int count,Scheme_Object ** vals)769 make_prim_closure(Scheme_Prim *fun, int eternal,
770 const char *name,
771 mzshort mina, mzshort maxa,
772 int flags,
773 mzshort minr, mzshort maxr,
774 int closed, int count, Scheme_Object **vals)
775 {
776 Scheme_Primitive_Proc *prim;
777 int hasr, size;
778
779 hasr = ((minr != 1) || (maxr != 1));
780 size = (hasr
781 ? sizeof(Scheme_Prim_W_Result_Arity)
782 : (closed
783 ? (sizeof(Scheme_Primitive_Closure)
784 + ((count - mzFLEX_DELTA) * sizeof(Scheme_Object *)))
785 : sizeof(Scheme_Primitive_Proc)));
786
787 if (eternal && scheme_starting_up && !closed)
788 prim = (Scheme_Primitive_Proc *)scheme_malloc_eternal_tagged(size);
789 else
790 prim = (Scheme_Primitive_Proc *)scheme_malloc_tagged(size);
791 prim->pp.so.type = scheme_prim_type;
792 prim->prim_val = (Scheme_Primitive_Closure_Proc *)fun;
793 prim->name = name;
794 prim->mina = mina;
795 if (maxa < 0)
796 maxa = SCHEME_MAX_ARGS + 1;
797 prim->mu.maxa = maxa;
798 prim->pp.flags = (flags
799 | (scheme_defining_primitives ? SCHEME_PRIM_IS_PRIMITIVE : 0)
800 | (hasr ? SCHEME_PRIM_IS_MULTI_RESULT : 0)
801 | (closed ? SCHEME_PRIM_IS_CLOSURE : 0));
802
803 if (hasr) {
804 ((Scheme_Prim_W_Result_Arity *)prim)->minr = minr;
805 ((Scheme_Prim_W_Result_Arity *)prim)->maxr = maxr;
806 }
807 if (closed) {
808 #ifdef MZ_PRECISE_GC
809 ((Scheme_Primitive_Closure *)prim)->count = count;
810 #endif
811 memcpy(((Scheme_Primitive_Closure *)prim)->val,
812 vals,
813 count * sizeof(Scheme_Object *));
814 }
815
816 return (Scheme_Object *)prim;
817 }
818
819 Scheme_Object *
scheme_make_prim_w_everything(Scheme_Prim * fun,int eternal,const char * name,mzshort mina,mzshort maxa,int flags,mzshort minr,mzshort maxr)820 scheme_make_prim_w_everything(Scheme_Prim *fun, int eternal,
821 const char *name,
822 mzshort mina, mzshort maxa,
823 int flags,
824 mzshort minr, mzshort maxr)
825 {
826 return make_prim_closure(fun, eternal,
827 name,
828 mina, maxa,
829 flags,
830 minr, maxr,
831 0, 0, NULL);
832 }
833
scheme_make_prim(Scheme_Prim * fun)834 Scheme_Object *scheme_make_prim(Scheme_Prim *fun)
835 {
836 return make_prim_closure(fun, 1, NULL, 0, -1, 0, 1, 1,
837 0, 0, NULL);
838 }
839
840 Scheme_Object *
scheme_make_noneternal_prim(Scheme_Prim * fun)841 scheme_make_noneternal_prim (Scheme_Prim *fun)
842 {
843 return make_prim_closure(fun, 0, NULL, 0, -1, 0, 1, 1,
844 0, 0, NULL);
845 }
846
847 Scheme_Object *
scheme_make_prim_w_arity(Scheme_Prim * fun,const char * name,mzshort mina,mzshort maxa)848 scheme_make_prim_w_arity(Scheme_Prim *fun, const char *name,
849 mzshort mina, mzshort maxa)
850 {
851 return make_prim_closure(fun, 1, name, mina, maxa, 0, 1, 1,
852 0, 0, NULL);
853 }
854
855 Scheme_Object *
scheme_make_noncm_prim(Scheme_Prim * fun,const char * name,mzshort mina,mzshort maxa)856 scheme_make_noncm_prim(Scheme_Prim *fun, const char *name,
857 mzshort mina, mzshort maxa)
858 {
859 /* A non-cm primitive leaves the mark stack unchanged when it returns,
860 it can't return multiple values or a tail call, and it cannot
861 use its third argument (i.e., the closure pointer) unless
862 SCHEME_PRIM_IS_CLOSURE is also set. */
863 return make_prim_closure(fun, 1, name, mina, maxa,
864 SCHEME_PRIM_OPT_NONCM,
865 1, 1,
866 0, 0, NULL);
867 }
868
869 Scheme_Object *
scheme_make_immed_prim(Scheme_Prim * fun,const char * name,mzshort mina,mzshort maxa)870 scheme_make_immed_prim(Scheme_Prim *fun, const char *name,
871 mzshort mina, mzshort maxa)
872 {
873 /* An immediate primitive is a non-cm primitive, and it doesn't
874 capture a continuation or extend the continuation in a way that
875 interacts with space safety (which implies no interposition via
876 chaperones), except maybe to raise an exception. */
877 return make_prim_closure(fun, 1, name, mina, maxa,
878 SCHEME_PRIM_OPT_IMMEDIATE,
879 1, 1,
880 0, 0, NULL);
881 }
882
883 Scheme_Object *
scheme_make_folding_prim(Scheme_Prim * fun,const char * name,mzshort mina,mzshort maxa,short folding)884 scheme_make_folding_prim(Scheme_Prim *fun, const char *name,
885 mzshort mina, mzshort maxa,
886 short folding)
887 {
888 /* A folding primitive is an immediate primitive, and for constant
889 arguments the result must be the same on all runs and platforms. */
890 return make_prim_closure(fun, 1, name, mina, maxa,
891 (folding
892 ? SCHEME_PRIM_OPT_FOLDING
893 : 0),
894 1, 1,
895 0, 0, NULL);
896 }
897
898 Scheme_Object *
scheme_make_noneternal_prim_w_arity(Scheme_Prim * fun,const char * name,mzshort mina,mzshort maxa)899 scheme_make_noneternal_prim_w_arity(Scheme_Prim *fun, const char *name,
900 mzshort mina, mzshort maxa)
901 {
902 return make_prim_closure(fun, 0, name, mina, maxa, 0, 1, 1,
903 0, 0, NULL);
904 }
905
scheme_make_prim_closure_w_arity(Scheme_Primitive_Closure_Proc * prim,int size,Scheme_Object ** vals,const char * name,mzshort mina,mzshort maxa)906 Scheme_Object *scheme_make_prim_closure_w_arity(Scheme_Primitive_Closure_Proc *prim,
907 int size, Scheme_Object **vals,
908 const char *name,
909 mzshort mina, mzshort maxa)
910 {
911 return make_prim_closure((Scheme_Prim *)prim, 1, name, mina, maxa, 0, 1, 1,
912 1, size, vals);
913
914 }
915
scheme_make_folding_prim_closure(Scheme_Primitive_Closure_Proc * prim,int size,Scheme_Object ** vals,const char * name,mzshort mina,mzshort maxa,short functional)916 Scheme_Object *scheme_make_folding_prim_closure(Scheme_Primitive_Closure_Proc *prim,
917 int size, Scheme_Object **vals,
918 const char *name,
919 mzshort mina, mzshort maxa,
920 short functional)
921 {
922 return make_prim_closure((Scheme_Prim *)prim, 1, name, mina, maxa,
923 (functional
924 ? SCHEME_PRIM_OPT_FOLDING
925 : 0),
926 1, 1,
927 1, size, vals);
928 }
929
930 Scheme_Object *
scheme_make_closed_prim_w_everything(Scheme_Closed_Prim * fun,void * data,const char * name,mzshort mina,mzshort maxa,short folding,mzshort minr,mzshort maxr)931 scheme_make_closed_prim_w_everything(Scheme_Closed_Prim *fun,
932 void *data,
933 const char *name,
934 mzshort mina, mzshort maxa,
935 short folding,
936 mzshort minr, mzshort maxr)
937 {
938 Scheme_Closed_Primitive_Proc *prim;
939 int hasr, size;
940
941 hasr = ((minr != 1) || (maxr != 1));
942 size = hasr ? sizeof(Scheme_Closed_Prim_W_Result_Arity) : sizeof(Scheme_Closed_Primitive_Proc);
943
944 prim = (Scheme_Closed_Primitive_Proc *)scheme_malloc_tagged(size);
945
946 prim->pp.so.type = scheme_closed_prim_type;
947 SCHEME_CLSD_PRIM(prim) = fun;
948 SCHEME_CLSD_PRIM_DATA(prim) = data;
949 prim->name = name;
950 prim->mina = mina;
951 prim->maxa = maxa;
952 prim->pp.flags = ((folding ? SCHEME_PRIM_OPT_FOLDING : 0)
953 | (scheme_defining_primitives ? SCHEME_PRIM_IS_PRIMITIVE : 0)
954 | (hasr ? SCHEME_PRIM_IS_MULTI_RESULT : 0));
955
956 if (hasr) {
957 ((Scheme_Closed_Prim_W_Result_Arity *)prim)->minr = minr;
958 ((Scheme_Closed_Prim_W_Result_Arity *)prim)->maxr = maxr;
959 }
960
961 return (Scheme_Object *)prim;
962 }
963
964 Scheme_Object *
scheme_make_folding_closed_prim(Scheme_Closed_Prim * fun,void * data,const char * name,mzshort mina,mzshort maxa,short folding)965 scheme_make_folding_closed_prim(Scheme_Closed_Prim *fun,
966 void *data,
967 const char *name,
968 mzshort mina, mzshort maxa,
969 short folding)
970 {
971 return scheme_make_closed_prim_w_everything(fun, data, name, mina, maxa, folding, 1, 1);
972 }
973
974 Scheme_Object *
scheme_make_closed_prim_w_arity(Scheme_Closed_Prim * fun,void * data,const char * name,mzshort mina,mzshort maxa)975 scheme_make_closed_prim_w_arity(Scheme_Closed_Prim *fun, void *data,
976 const char *name, mzshort mina, mzshort maxa)
977 {
978 return scheme_make_closed_prim_w_everything(fun, data, name, mina, maxa, 0, 1, 1);
979 }
980
981 Scheme_Object *
scheme_make_closed_prim(Scheme_Closed_Prim * fun,void * data)982 scheme_make_closed_prim(Scheme_Closed_Prim *fun, void *data)
983 {
984 return scheme_make_closed_prim_w_everything(fun, data, NULL, 0, -1, 0, 1, 1);
985 }
986
scheme_prim_is_method(Scheme_Object * o)987 void scheme_prim_is_method(Scheme_Object *o)
988 {
989 scheme_signal_error("no longer supported");
990 }
991
scheme_has_method_property(Scheme_Object * code)992 int scheme_has_method_property(Scheme_Object *code)
993 {
994 return SCHEME_TRUEP(scheme_stx_property(code, is_method_symbol, NULL));
995 }
996
scheme_intern_prim_opt_flags(int flags)997 int scheme_intern_prim_opt_flags(int flags)
998 {
999 int i;
1000
1001 if (!flags) return 0;
1002
1003 for (i = 1; i < (1 << SCHEME_PRIM_OPT_INDEX_SIZE); i++) {
1004 if (scheme_prim_opt_flags[i] == flags)
1005 return (i << SCHEME_PRIM_OPT_INDEX_SHIFT);
1006 else if (!scheme_prim_opt_flags[i]) {
1007 scheme_prim_opt_flags[i] = flags;
1008 return (i << SCHEME_PRIM_OPT_INDEX_SHIFT);
1009 }
1010 }
1011
1012 scheme_log_abort("too many flag combinations");
1013 abort();
1014
1015 return 0;
1016 }
1017
1018 /*========================================================================*/
1019 /* prompt helpers */
1020 /*========================================================================*/
1021
initialize_prompt(Scheme_Thread * p,Scheme_Prompt * prompt,void * stack_boundary,int is_barrier)1022 static void initialize_prompt(Scheme_Thread *p, Scheme_Prompt *prompt, void *stack_boundary, int is_barrier)
1023 {
1024 prompt->is_barrier = is_barrier;
1025 prompt->stack_boundary = stack_boundary;
1026 if (is_barrier) {
1027 /* Avoid leak in case barrier is retained longer than the rest of the stack */
1028 Scheme_Object *ref;
1029 ref = scheme_make_weak_box((Scheme_Object *)MZ_RUNSTACK_START);
1030 prompt->u.runstack_boundary_start_ref = ref;
1031 prompt->weak_boundary = 1;
1032 } else
1033 prompt->u.runstack_boundary_start = MZ_RUNSTACK_START;
1034 prompt->runstack_boundary_offset = (MZ_RUNSTACK - MZ_RUNSTACK_START);
1035 prompt->mark_boundary = MZ_CONT_MARK_STACK;
1036 prompt->boundary_mark_pos = MZ_CONT_MARK_POS;
1037 }
1038
scheme_prompt_runstack_boundary_start(Scheme_Prompt * p)1039 Scheme_Object **scheme_prompt_runstack_boundary_start(Scheme_Prompt *p)
1040 {
1041 if (p->weak_boundary)
1042 return (Scheme_Object **)(SCHEME_BOX_VAL(p->u.runstack_boundary_start_ref));
1043 else
1044 return p->u.runstack_boundary_start;
1045 }
1046
init_prompt_id(Scheme_Prompt * prompt)1047 static void init_prompt_id(Scheme_Prompt *prompt)
1048 {
1049 Scheme_Object *id;
1050
1051 if (!prompt->id) {
1052 id = scheme_make_pair(scheme_false, scheme_false);
1053 prompt->id = id;
1054 }
1055 }
1056
make_weak_prompt(Scheme_Prompt * p)1057 Scheme_Prompt *make_weak_prompt(Scheme_Prompt *p)
1058 {
1059 Scheme_Prompt *p2;
1060 Scheme_Object *ref;
1061
1062 if (p->weak_boundary)
1063 return p;
1064
1065 init_prompt_id(p);
1066
1067 p2 = MALLOC_ONE_TAGGED(Scheme_Prompt);
1068 memcpy(p2, p, sizeof(Scheme_Prompt));
1069
1070 ref = scheme_make_weak_box((Scheme_Object *)p2->u.runstack_boundary_start);
1071 p2->u.runstack_boundary_start_ref = ref;
1072 p2->weak_boundary = 1;
1073
1074 return p2;
1075 }
1076
1077 /*========================================================================*/
1078 /* stack-overflow wrapper */
1079 /*========================================================================*/
1080
1081 typedef Scheme_Object *(*Overflow_K_Proc)(void);
1082
1083 THREAD_LOCAL_DECL(Scheme_Overflow_Jmp *scheme_overflow_jmp);
1084 THREAD_LOCAL_DECL(void *scheme_overflow_stack_start);
1085
1086 MZ_DO_NOT_INLINE(void scheme_really_create_overflow(void *stack_base));
1087
scheme_really_create_overflow(void * stack_base)1088 void scheme_really_create_overflow(void *stack_base)
1089 {
1090 Scheme_Overflow_Jmp *jmp;
1091
1092 if (scheme_overflow_jmp)
1093 return;
1094
1095 scheme_overflow_stack_start = stack_base;
1096
1097 jmp = MALLOC_ONE_RT(Scheme_Overflow_Jmp);
1098 #ifdef MZTAG_REQUIRED
1099 jmp->type = scheme_rt_overflow_jmp;
1100 #endif
1101
1102 scheme_init_jmpup_buf(&jmp->cont);
1103 if (scheme_setjmpup(&jmp->cont, jmp, stack_base)) {
1104 /* A jump into here is a request to handle overflow.
1105 The way to continue is in p->overflow_k.
1106 When we get back, put the result into
1107 scheme_overflow_reply. The route to return is
1108 in the thread's `overflow' field. */
1109 Scheme_Thread * volatile p;
1110 Scheme_Overflow * volatile overflow;
1111 mz_jmp_buf nestedbuf;
1112
1113 p = scheme_current_thread;
1114 overflow = p->overflow;
1115
1116 overflow->jmp->savebuf = p->error_buf;
1117 p->error_buf = &nestedbuf;
1118 if (scheme_setjmp(nestedbuf)) {
1119 /* there was an escape from the overflow */
1120 p = scheme_current_thread;
1121 p->overflow_reply = NULL; /* means "continue the error" */
1122 } else {
1123 void *p1, *p2, *p3, *p4, *p5;
1124 intptr_t i1, i2, i3, i4;
1125 Overflow_K_Proc f = p->overflow_k;
1126 Scheme_Object *reply;
1127
1128 p1 = p->ku.k.p1;
1129 p2 = p->ku.k.p2;
1130 p3 = p->ku.k.p3;
1131 p4 = p->ku.k.p4;
1132 p5 = p->ku.k.p5;
1133 i1 = p->ku.k.i1;
1134 i2 = p->ku.k.i2;
1135 i3 = p->ku.k.i3;
1136 i4 = p->ku.k.i4;
1137
1138 /* stack overflow is a lot of work; force a sleep */
1139 scheme_thread_block(0);
1140 p->ran_some = 1;
1141
1142 p->ku.k.p1 = p1;
1143 p->ku.k.p2 = p2;
1144 p->ku.k.p3 = p3;
1145 p->ku.k.p4 = p4;
1146 p->ku.k.p5 = p5;
1147 p->ku.k.i1 = i1;
1148 p->ku.k.i2 = i2;
1149 p->ku.k.i3 = i3;
1150 p->ku.k.i4 = i4;
1151
1152 reply = f();
1153 scheme_overflow_reply = reply;
1154
1155 /* At the time of writing, there appear to be no GCs on the
1156 longjmp return from stack overflow. Just in case, though,
1157 it seems better to protect multiple-value and tail-call
1158 results from any GC that might be introduced one day. */
1159 if (reply == SCHEME_MULTIPLE_VALUES) {
1160 p = scheme_current_thread;
1161 if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
1162 p->values_buffer = NULL;
1163 } else if (reply == SCHEME_TAIL_CALL_WAITING) {
1164 p = scheme_current_thread;
1165 if (p->ku.apply.tail_rands == p->tail_buffer)
1166 scheme_realloc_tail_buffer(p);
1167 }
1168 }
1169
1170 p = scheme_current_thread;
1171 overflow = p->overflow;
1172 p->stack_start = overflow->stack_start;
1173
1174 /* Reset overflow buffer and continue */
1175 scheme_longjmpup(&overflow->jmp->cont);
1176 }
1177
1178 if (scheme_overflow_jmp) {
1179 scheme_signal_error("shouldn't get here!");
1180 }
1181
1182 scheme_overflow_jmp = jmp;
1183 }
1184
scheme_create_overflow(void)1185 void scheme_create_overflow(void)
1186 {
1187 void *stack_marker;
1188 scheme_really_create_overflow(PROMPT_STACK(stack_marker));
1189 stack_marker = NULL; /* to ensure that we get __gc_var_stack__ in 3m */
1190 }
1191
scheme_init_overflow(void)1192 void scheme_init_overflow(void)
1193 {
1194 REGISTER_SO(scheme_overflow_jmp);
1195 }
1196
scheme_reset_overflow(void)1197 void scheme_reset_overflow(void)
1198 {
1199 scheme_overflow_jmp = NULL;
1200 }
1201
1202 /*========================================================================*/
1203 /* entry continuation barrier */
1204 /*========================================================================*/
1205
allocate_prompt(Scheme_Prompt ** cached_prompt)1206 static Scheme_Prompt *allocate_prompt(Scheme_Prompt **cached_prompt) {
1207 Scheme_Prompt *prompt;
1208 if (*cached_prompt) {
1209 prompt = *cached_prompt;
1210 *cached_prompt = NULL;
1211 } else {
1212 prompt = MALLOC_ONE_TAGGED(Scheme_Prompt);
1213 prompt->so.type = scheme_prompt_type;
1214 }
1215 return prompt;
1216 }
1217
apply_again_k(void)1218 static void *apply_again_k(void)
1219 {
1220 Scheme_Thread *p = scheme_current_thread;
1221 Scheme_Object *val = p->ku.k.p1;
1222 int num_vals = p->ku.k.i1;
1223
1224 p->ku.k.p1 = NULL;
1225
1226 if (num_vals != 1) {
1227 scheme_wrong_return_arity("call-with-continuation-prompt", 1, num_vals, (Scheme_Object **)val,
1228 "\n in: application of default prompt handler");
1229 return NULL;
1230 } else {
1231 scheme_check_proc_arity("default-continuation-prompt-handler", 0, 0, 1, &val);
1232 return (void *)_scheme_apply(val, 0, NULL);
1233 }
1234 }
1235
scheme_top_level_do(void * (* k)(void),int eb)1236 void *scheme_top_level_do(void *(*k)(void), int eb) {
1237 return scheme_top_level_do_worker(k, eb, 0);
1238 }
1239
scheme_top_level_do_worker(void * (* k)(void),int eb,int new_thread)1240 void *scheme_top_level_do_worker(void *(*k)(void), int eb, int new_thread)
1241 {
1242 /* Wraps a function `k' with a handler for stack overflows and
1243 barriers to full-continuation jumps. No barrier if !eb. */
1244 void * v;
1245 Scheme_Prompt * volatile prompt = NULL;
1246 mz_jmp_buf *save;
1247 mz_jmp_buf newbuf;
1248 Scheme_Stack_State envss;
1249 Scheme_Thread * volatile p = scheme_current_thread;
1250 volatile int old_pcc = scheme_prompt_capture_count;
1251 Scheme_Cont_Frame_Data cframe;
1252 volatile int need_final_abort = 0;
1253 #ifdef MZ_PRECISE_GC
1254 void *external_stack;
1255 #endif
1256 int num_vals = p->ku.k.i1;
1257 void *val = p->ku.k.p1;
1258
1259 if (scheme_active_but_sleeping)
1260 scheme_wake_up();
1261
1262 if (eb) {
1263 prompt = allocate_prompt(&available_prompt);
1264 initialize_prompt(p, prompt, PROMPT_STACK(prompt), !new_thread);
1265 }
1266
1267 #ifdef MZ_PRECISE_GC
1268 if (scheme_get_external_stack_val)
1269 external_stack = scheme_get_external_stack_val();
1270 else
1271 external_stack = NULL;
1272 #endif
1273
1274 scheme_create_overflow(); /* needed even if scheme_overflow_jmp is already set */
1275
1276 save = p->error_buf;
1277
1278 while (1) {
1279
1280 scheme_save_env_stack_w_thread(envss, p);
1281
1282 if (prompt) {
1283 scheme_push_continuation_frame(&cframe);
1284 scheme_set_cont_mark(barrier_prompt_key, (Scheme_Object *)prompt);
1285 }
1286
1287 p->error_buf = &newbuf;
1288
1289 if (scheme_setjmp(newbuf)) {
1290 int again;
1291
1292 p = scheme_current_thread;
1293
1294 if (SAME_OBJ(p->cjs.jumping_to_continuation, (Scheme_Object *)original_default_prompt)) {
1295 /* an abort to the thread start; act like the default prompt handler,
1296 but remember to jump again */
1297 num_vals = p->cjs.num_vals;
1298 val = p->cjs.val;
1299 reset_cjs(&p->cjs);
1300 k = apply_again_k;
1301 need_final_abort = 1;
1302 again = 1;
1303 } else {
1304 num_vals = 0;
1305 val = NULL;
1306 again = 0;
1307 }
1308
1309 if (!new_thread || again) {
1310 scheme_restore_env_stack_w_thread(envss, p);
1311 #ifdef MZ_PRECISE_GC
1312 if (scheme_set_external_stack_val)
1313 scheme_set_external_stack_val(external_stack);
1314 #endif
1315 if (prompt) {
1316 scheme_pop_continuation_frame(&cframe);
1317 if (!again) {
1318 if (old_pcc == scheme_prompt_capture_count) {
1319 /* It wasn't used */
1320 available_prompt = prompt;
1321 }
1322 }
1323 }
1324 }
1325
1326 if (!again)
1327 scheme_longjmp(*save, 1);
1328 } else {
1329 if (new_thread) {
1330 /* check for initial break before we do anything */
1331 scheme_check_break_now();
1332 }
1333
1334 p->ku.k.i1 = num_vals;
1335 p->ku.k.p1 = val;
1336
1337 v = k();
1338
1339 break;
1340 }
1341 }
1342
1343 /* IMPORTANT: no GCs from here to return, since v
1344 may refer to multiple values, and we don't want the
1345 multiple-value array cleared. */
1346
1347 if (!new_thread) {
1348 p = scheme_current_thread;
1349
1350 p->error_buf = save;
1351 }
1352
1353 if (prompt) {
1354 scheme_pop_continuation_frame(&cframe);
1355 if (old_pcc == scheme_prompt_capture_count) {
1356 /* It wasn't used */
1357 available_prompt = prompt;
1358 }
1359 }
1360
1361 if (scheme_active_but_sleeping)
1362 scheme_wake_up();
1363
1364 if (need_final_abort) {
1365 p = scheme_current_thread;
1366 scheme_longjmp(*p->error_buf, 1);
1367 }
1368
1369 return (Scheme_Object *)v;
1370 }
1371
1372
scheme_clear_prompt_cache()1373 void scheme_clear_prompt_cache()
1374 {
1375 available_prompt = NULL;
1376 available_cws_prompt = NULL;
1377 available_regular_prompt = NULL;
1378 available_prompt_dw = NULL;
1379 available_prompt_mc = NULL;
1380 }
1381
ensure_overflow_id(Scheme_Overflow * overflow)1382 static void ensure_overflow_id(Scheme_Overflow *overflow)
1383 {
1384 void *id;
1385 if (!overflow->id) {
1386 if (overflow->jmp) {
1387 overflow->id = overflow->jmp;
1388 } else {
1389 id = scheme_malloc_atomic(4);
1390 overflow->id = id;
1391 }
1392 }
1393 }
1394
scheme_ensure_dw_id(Scheme_Dynamic_Wind * dw)1395 void scheme_ensure_dw_id(Scheme_Dynamic_Wind *dw)
1396 {
1397 void *id;
1398 if (!dw->id) {
1399 id = scheme_malloc_atomic(4);
1400 dw->id = id;
1401 }
1402 }
1403
1404 /*========================================================================*/
1405 /* procedure application evaluation */
1406 /*========================================================================*/
1407
1408 static Scheme_Object *
force_values(Scheme_Object * obj,int multi_ok)1409 force_values(Scheme_Object *obj, int multi_ok)
1410 /* Called where _scheme_apply() or _scheme_value() might return a
1411 a tail-call-waiting trampoline token. */
1412 {
1413 if (SAME_OBJ(obj, SCHEME_TAIL_CALL_WAITING)) {
1414 Scheme_Thread *p = scheme_current_thread;
1415 GC_CAN_IGNORE Scheme_Object *rator, *result;
1416 GC_CAN_IGNORE Scheme_Object **rands;
1417 int argc = p->ku.apply.tail_num_rands, popc = 0;
1418
1419 rands = p->ku.apply.tail_rands;
1420
1421 /* Watch out for use of tail buffer: */
1422 if (rands == p->tail_buffer) {
1423 GC_CAN_IGNORE Scheme_Object **runstack = MZ_RUNSTACK;
1424 if (((runstack - MZ_RUNSTACK_START) - argc) > SCHEME_TAIL_COPY_THRESHOLD) {
1425 /* There's room on the runstack; use that instead of allocating a new buffer */
1426 runstack -= argc;
1427 memcpy(runstack, rands, argc * sizeof(Scheme_Object *));
1428 rands = runstack;
1429 popc = argc;
1430 MZ_RUNSTACK = rands;
1431 } else {
1432 scheme_realloc_tail_buffer(p);
1433 rands = p->ku.apply.tail_rands;
1434 }
1435 }
1436
1437 rator = p->ku.apply.tail_rator;
1438 p->ku.apply.tail_rator = NULL;
1439 p->ku.apply.tail_rands = NULL;
1440
1441 if (multi_ok)
1442 result = _scheme_apply_multi(rator, argc, rands);
1443 else
1444 result = _scheme_apply(rator, argc, rands);
1445
1446 if (popc)
1447 MZ_RUNSTACK += popc;
1448
1449 return result;
1450 } else if (SAME_OBJ(obj, SCHEME_EVAL_WAITING)) {
1451 Scheme_Thread *p = scheme_current_thread;
1452 if (multi_ok)
1453 return _scheme_eval_linked_expr_multi(p->ku.eval.wait_expr);
1454 else
1455 return _scheme_eval_linked_expr(p->ku.eval.wait_expr);
1456 } else if (obj)
1457 return obj;
1458 else
1459 return scheme_void;
1460 }
1461
1462 Scheme_Object *
scheme_force_value(Scheme_Object * obj)1463 scheme_force_value(Scheme_Object *obj)
1464 {
1465 return force_values(obj, 1);
1466 }
1467
1468 Scheme_Object *
scheme_force_one_value(Scheme_Object * obj)1469 scheme_force_one_value(Scheme_Object *obj)
1470 {
1471 return force_values(obj, 0);
1472 }
1473
1474 Scheme_Object *
scheme_force_value_same_mark(Scheme_Object * obj)1475 scheme_force_value_same_mark(Scheme_Object *obj)
1476 {
1477 Scheme_Object *v;
1478
1479 MZ_CONT_MARK_POS -= 2;
1480 /* At this point, if the thread is swapped out and we attempt to get
1481 the continuation marks of the thread, then MZ_CONT_MARK_POS may
1482 be inconsistent with the first mark on the stack. We assume that
1483 a thread swap will not happen until scheme_do_eval(), where
1484 the first possibility for a swap is on stack overflow, and
1485 in that case MZ_CONT_MARK_POS is adjusted back before overflow
1486 handling (which can cause the thread to swap out). */
1487
1488 v = force_values(obj, 1);
1489
1490 MZ_CONT_MARK_POS += 2;
1491
1492 return v;
1493 }
1494
1495 Scheme_Object *
scheme_force_one_value_same_mark(Scheme_Object * obj)1496 scheme_force_one_value_same_mark(Scheme_Object *obj)
1497 {
1498 Scheme_Object *v;
1499
1500 MZ_CONT_MARK_POS -= 2;
1501 /* See above about thread swaps */
1502
1503 v = force_values(obj, 0);
1504
1505 MZ_CONT_MARK_POS += 2;
1506
1507 return v;
1508 }
1509
apply_k(void)1510 static void *apply_k(void)
1511 {
1512 Scheme_Thread *p = scheme_current_thread;
1513 Scheme_Object *rator;
1514 int num_rands;
1515 Scheme_Object **rands;
1516
1517 rator = (Scheme_Object *)p->ku.k.p1;
1518 rands = (Scheme_Object **)p->ku.k.p2;
1519 num_rands = p->ku.k.i1;
1520
1521 p->ku.k.p1 = NULL;
1522 p->ku.k.p2 = NULL;
1523
1524 if (p->ku.k.i2)
1525 return (void *)_scheme_apply_multi_wp(rator, num_rands, rands, p);
1526 else
1527 return (void *)_scheme_apply_wp(rator, num_rands, rands, p);
1528 }
1529
1530 static Scheme_Object *
_apply(Scheme_Object * rator,int num_rands,Scheme_Object ** rands,int multi,int eb)1531 _apply(Scheme_Object *rator, int num_rands, Scheme_Object **rands, int multi, int eb)
1532 {
1533 Scheme_Thread *p = scheme_current_thread;
1534
1535 p->ku.k.p1 = rator;
1536 p->ku.k.p2 = rands;
1537 p->ku.k.i1 = num_rands;
1538 p->ku.k.i2 = multi;
1539
1540 return (Scheme_Object *)scheme_top_level_do(apply_k, eb);
1541 }
1542
1543 Scheme_Object *
scheme_apply(Scheme_Object * rator,int num_rands,Scheme_Object ** rands)1544 scheme_apply(Scheme_Object *rator, int num_rands, Scheme_Object **rands)
1545 {
1546 return _apply(rator, num_rands, rands, 0, 1);
1547 }
1548
1549 Scheme_Object *
scheme_apply_multi(Scheme_Object * rator,int num_rands,Scheme_Object ** rands)1550 scheme_apply_multi(Scheme_Object *rator, int num_rands, Scheme_Object **rands)
1551 {
1552 return _apply(rator, num_rands, rands, 1, 1);
1553 }
1554
1555 Scheme_Object *
scheme_apply_thread_thunk(Scheme_Object * rator)1556 scheme_apply_thread_thunk(Scheme_Object *rator)
1557 {
1558 Scheme_Thread *p = scheme_current_thread;
1559
1560 p->ku.k.p1 = rator;
1561 p->ku.k.p2 = NULL;
1562 p->ku.k.i1 = 0;
1563 p->ku.k.i2 = 1;
1564
1565 return (Scheme_Object *)scheme_top_level_do_worker(apply_k, 1, 1);
1566 }
1567
1568 Scheme_Object *
scheme_apply_no_eb(Scheme_Object * rator,int num_rands,Scheme_Object ** rands)1569 scheme_apply_no_eb(Scheme_Object *rator, int num_rands, Scheme_Object **rands)
1570 {
1571 return _apply(rator, num_rands, rands, 0, 0);
1572 }
1573
1574 Scheme_Object *
scheme_apply_multi_no_eb(Scheme_Object * rator,int num_rands,Scheme_Object ** rands)1575 scheme_apply_multi_no_eb(Scheme_Object *rator, int num_rands, Scheme_Object **rands)
1576 {
1577 return _apply(rator, num_rands, rands, 1, 0);
1578 }
1579
1580 static Scheme_Object *
finish_apply_with_prompt(void * _data,int argc,Scheme_Object ** argv)1581 finish_apply_with_prompt(void *_data, int argc, Scheme_Object **argv)
1582 {
1583 void **data = (void **)_data;
1584 Scheme_Object *rator, *is_multi;
1585
1586 argv = (Scheme_Object **)_data;
1587 for (argc = 0; data[argc]; argc++) { }
1588
1589 rator = (Scheme_Object *)data[argc+1];
1590 is_multi = (Scheme_Object *)data[argc+2];
1591
1592 if (SCHEME_TRUEP(is_multi))
1593 return _scheme_apply_multi(rator, argc, argv);
1594 else
1595 return _scheme_apply(rator, argc, argv);
1596 }
1597
1598 static Scheme_Object *
do_apply_with_prompt(Scheme_Object * rator,int num_rands,Scheme_Object ** rands,int multi,int top_level)1599 do_apply_with_prompt(Scheme_Object *rator, int num_rands, Scheme_Object **rands, int multi, int top_level)
1600 {
1601 void **a;
1602 int i;
1603
1604 a = MALLOC_N(void*, 3 + num_rands);
1605
1606 for (i = 0; i < num_rands; i++) {
1607 a[i] = rands[i];
1608 }
1609 a[num_rands] = NULL;
1610 a[num_rands + 1] = rator;
1611 a[num_rands + 2] = (multi ? scheme_true : scheme_false);
1612
1613 if (top_level) {
1614 if (multi)
1615 return scheme_call_with_prompt_multi(finish_apply_with_prompt, a);
1616 else
1617 return scheme_call_with_prompt(finish_apply_with_prompt, a);
1618 } else {
1619 if (multi)
1620 return _scheme_call_with_prompt_multi(finish_apply_with_prompt, a);
1621 else
1622 return _scheme_call_with_prompt(finish_apply_with_prompt, a);
1623 }
1624 }
1625
1626 Scheme_Object *
scheme_apply_with_prompt(Scheme_Object * rator,int num_rands,Scheme_Object ** rands)1627 scheme_apply_with_prompt(Scheme_Object *rator, int num_rands, Scheme_Object **rands)
1628 {
1629 return do_apply_with_prompt(rator, num_rands, rands, 0, 1);
1630 }
1631
1632 Scheme_Object *
scheme_apply_multi_with_prompt(Scheme_Object * rator,int num_rands,Scheme_Object ** rands)1633 scheme_apply_multi_with_prompt(Scheme_Object *rator, int num_rands, Scheme_Object **rands)
1634 {
1635 return do_apply_with_prompt(rator, num_rands, rands, 1, 1);
1636 }
1637
1638 Scheme_Object *
_scheme_apply_with_prompt(Scheme_Object * rator,int num_rands,Scheme_Object ** rands)1639 _scheme_apply_with_prompt(Scheme_Object *rator, int num_rands, Scheme_Object **rands)
1640 {
1641 return do_apply_with_prompt(rator, num_rands, rands, 0, 0);
1642 }
1643
_scheme_apply_multi_with_prompt(Scheme_Object * rator,int num_rands,Scheme_Object ** rands)1644 Scheme_Object *_scheme_apply_multi_with_prompt(Scheme_Object *rator, int num_rands, Scheme_Object **rands)
1645 {
1646 return do_apply_with_prompt(rator, num_rands, rands, 1, 0);
1647 }
1648
1649 #ifdef INSTRUMENT_PRIMITIVES
1650 extern int g_print_prims;
1651 #endif
1652
1653 Scheme_Object *
scheme_tail_apply(Scheme_Object * rator,int num_rands,Scheme_Object ** rands)1654 scheme_tail_apply (Scheme_Object *rator, int num_rands, Scheme_Object **rands)
1655 {
1656 /* NOTE: apply_values_execute (in syntax.c) and
1657 tail_call_with_values_from_multiple_result (in jit.c)
1658 assume that this function won't allocate when
1659 num_rands <= p->tail_buffer_size. */
1660 int i;
1661 Scheme_Thread *p = scheme_current_thread;
1662
1663 p->ku.apply.tail_rator = rator;
1664 p->ku.apply.tail_num_rands = num_rands;
1665
1666 if (num_rands) {
1667 Scheme_Object **a;
1668 if (num_rands > p->tail_buffer_size) {
1669 a = MALLOC_N(Scheme_Object *, num_rands);
1670 p->tail_buffer = a;
1671 p->tail_buffer_size = num_rands;
1672 } else
1673 a = p->tail_buffer;
1674 p->ku.apply.tail_rands = a;
1675 for (i = num_rands; i--; ) {
1676 a[i] = rands[i];
1677 }
1678 } else
1679 p->ku.apply.tail_rands = NULL;
1680
1681 return SCHEME_TAIL_CALL_WAITING;
1682 }
1683
1684 Scheme_Object *
scheme_tail_apply_no_copy(Scheme_Object * rator,int num_rands,Scheme_Object ** rands)1685 scheme_tail_apply_no_copy (Scheme_Object *rator, int num_rands,
1686 Scheme_Object **rands)
1687 {
1688 Scheme_Thread *p = scheme_current_thread;
1689
1690 p->ku.apply.tail_rator = rator;
1691 p->ku.apply.tail_num_rands = num_rands;
1692 p->ku.apply.tail_rands = rands;
1693
1694 return SCHEME_TAIL_CALL_WAITING;
1695 }
1696
1697 static
1698 Scheme_Object *
X_scheme_apply_to_list(Scheme_Object * rator,Scheme_Object * rands,int force,int top_level)1699 X_scheme_apply_to_list(Scheme_Object *rator, Scheme_Object *rands, int force,
1700 int top_level)
1701 {
1702 int num_rands, i;
1703 Scheme_Object **rands_vec;
1704
1705 num_rands = scheme_list_length(rands);
1706 rands_vec = MALLOC_N(Scheme_Object *, num_rands);
1707
1708 for (i = 0; i < num_rands ; i++) {
1709 if (!SCHEME_PAIRP(rands)) {
1710 scheme_signal_error("bad application form");
1711 }
1712 rands_vec[i] = SCHEME_CAR(rands);
1713 rands = SCHEME_CDR(rands);
1714 }
1715
1716 if (top_level) {
1717 if (force)
1718 return scheme_apply(rator, num_rands, rands_vec);
1719 else
1720 return scheme_tail_apply(rator, num_rands, rands_vec);
1721 } else {
1722 if (force)
1723 return _scheme_apply(rator, num_rands, rands_vec);
1724 else
1725 return _scheme_tail_apply(rator, num_rands, rands_vec);
1726 }
1727 }
1728
1729 Scheme_Object *
scheme_apply_to_list(Scheme_Object * rator,Scheme_Object * rands)1730 scheme_apply_to_list (Scheme_Object *rator, Scheme_Object *rands)
1731 {
1732 return X_scheme_apply_to_list(rator, rands, 1, 1);
1733 }
1734
1735 Scheme_Object *
scheme_tail_apply_to_list(Scheme_Object * rator,Scheme_Object * rands)1736 scheme_tail_apply_to_list (Scheme_Object *rator, Scheme_Object *rands)
1737 {
1738 return X_scheme_apply_to_list(rator, rands, 0, 1);
1739 }
1740
1741 Scheme_Object *
_scheme_apply_to_list(Scheme_Object * rator,Scheme_Object * rands)1742 _scheme_apply_to_list (Scheme_Object *rator, Scheme_Object *rands)
1743 {
1744 return X_scheme_apply_to_list(rator, rands, 1, 0);
1745 }
1746
1747 Scheme_Object *
_scheme_tail_apply_to_list(Scheme_Object * rator,Scheme_Object * rands)1748 _scheme_tail_apply_to_list (Scheme_Object *rator, Scheme_Object *rands)
1749 {
1750 return X_scheme_apply_to_list(rator, rands, 0, 0);
1751 }
1752
1753 /*========================================================================*/
1754 /* arity */
1755 /*========================================================================*/
1756
make_arity(intptr_t mina,intptr_t maxa,int mode)1757 static Scheme_Object *make_arity(intptr_t mina, intptr_t maxa, int mode)
1758 {
1759 if (mina == maxa)
1760 return scheme_make_integer(mina);
1761 else if (maxa == -1) {
1762 if (mode == -3) {
1763 return scheme_make_integer(-(mina+1));
1764 } else {
1765 Scheme_Object *p[1];
1766 p[0] = scheme_make_integer(mina);
1767 return scheme_make_struct_instance(scheme_arity_at_least, 1, p);
1768 }
1769 } else {
1770 intptr_t i;
1771 Scheme_Object *l = scheme_null;
1772
1773 for (i = maxa; i >= mina; --i) {
1774 l = scheme_make_pair(scheme_make_integer(i), l);
1775 }
1776
1777 return l;
1778 }
1779 }
1780
scheme_make_arity(mzshort mina,mzshort maxa)1781 Scheme_Object *scheme_make_arity(mzshort mina, mzshort maxa)
1782 {
1783 return make_arity(mina, maxa, -1);
1784 }
1785
shift_for_drop(Scheme_Object * n,int drop)1786 Scheme_Object *shift_for_drop(Scheme_Object *n, int drop)
1787 {
1788 Scheme_Object *a[2];
1789 a[0] = n;
1790 a[1] = scheme_make_integer(-drop);
1791 return scheme_bitwise_shift(2, a);
1792 }
1793
make_shifted_one(intptr_t n)1794 static Scheme_Object *make_shifted_one(intptr_t n)
1795 {
1796 Scheme_Object *a[2];
1797 a[0] = scheme_make_integer(1);
1798 a[1] = scheme_make_integer(n);
1799 return scheme_bitwise_shift(2, a);
1800 }
1801
make_arity_mask(intptr_t mina,intptr_t maxa)1802 static Scheme_Object *make_arity_mask(intptr_t mina, intptr_t maxa)
1803 {
1804 /* Generate a mask */
1805 if (mina == maxa) {
1806 if (mina < SCHEME_MAX_FAST_ARITY_CHECK)
1807 return scheme_make_integer(1 << mina);
1808 else
1809 return make_shifted_one(mina);
1810 } else if (maxa == -1) {
1811 if (mina < SCHEME_MAX_FAST_ARITY_CHECK) {
1812 return scheme_make_integer(((1 << mina) - 1) ^ (intptr_t)-1);
1813 } else {
1814 return scheme_bin_bitwise_xor(scheme_bin_minus(make_shifted_one(mina), scheme_make_integer(1)),
1815 scheme_make_integer(-1));
1816 }
1817 } else {
1818 mzshort i;
1819 Scheme_Object *mask = scheme_make_integer(0);
1820
1821 for (i = mina; i <= maxa; i++) {
1822 mask = scheme_bin_bitwise_or(make_shifted_one(i), mask);
1823 }
1824
1825 return mask;
1826 }
1827 }
1828
scheme_make_arity_mask(intptr_t mina,intptr_t maxa)1829 Scheme_Object *scheme_make_arity_mask(intptr_t mina, intptr_t maxa)
1830 {
1831 return make_arity_mask(mina, maxa);
1832 }
1833
scheme_fast_check_arity(Scheme_Object * p,int a)1834 int scheme_fast_check_arity(Scheme_Object *p, int a)
1835 /* Faster version of get_or_check_arity() in check mode;
1836 a 0 result means "maybe" */
1837 {
1838 Scheme_Type type;
1839 int mina, maxa;
1840
1841 type = SCHEME_TYPE(p);
1842 if (type == scheme_prim_type) {
1843 mina = ((Scheme_Primitive_Proc *)p)->mina;
1844 maxa = ((Scheme_Primitive_Proc *)p)->mu.maxa;
1845 if (mina < 0)
1846 return 0;
1847 else {
1848 if (maxa > SCHEME_MAX_ARGS)
1849 maxa = -1;
1850 }
1851 } else if (type == scheme_closed_prim_type) {
1852 mina = ((Scheme_Closed_Primitive_Proc *)p)->mina;
1853 maxa = ((Scheme_Closed_Primitive_Proc *)p)->maxa;
1854 if (mina == -2)
1855 return 0;
1856 } else
1857 return 0;
1858
1859 if (a >= mina && (maxa < 0 || a <= maxa))
1860 return 1;
1861
1862 return 0;
1863 }
1864
get_or_check_arity(Scheme_Object * p,intptr_t a,Scheme_Object * bign,int inc_ok)1865 static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Object *bign, int inc_ok)
1866 /* a == -1 => get arity
1867 a == -2 => check for allowing bignum
1868 a == -3 => like -1, but alternate representation using negative numbers for arity-at-least
1869 a == -4 => mask */
1870 {
1871 Scheme_Type type;
1872 mzshort mina, maxa;
1873 int drop = 0, cases_count = 0;
1874 mzshort *cases = NULL;
1875
1876 top:
1877
1878 type = SCHEME_TYPE(p);
1879 if (type == scheme_prim_type) {
1880 mina = ((Scheme_Primitive_Proc *)p)->mina;
1881 maxa = ((Scheme_Primitive_Proc *)p)->mu.maxa;
1882 if (mina < 0) {
1883 cases = ((Scheme_Primitive_Proc *)p)->mu.cases;
1884 cases_count = -(mina + 1);
1885 } else {
1886 if (maxa > SCHEME_MAX_ARGS)
1887 maxa = -1;
1888 }
1889 } else if (type == scheme_closed_prim_type) {
1890 mina = ((Scheme_Closed_Primitive_Proc *)p)->mina;
1891 maxa = ((Scheme_Closed_Primitive_Proc *)p)->maxa;
1892 if (mina == -2) {
1893 cases_count = -maxa;
1894 cases = ((Scheme_Closed_Case_Primitive_Proc *)p)->cases;
1895 }
1896 } else if (type == scheme_cont_type || type == scheme_escaping_cont_type) {
1897 mina = 0;
1898 maxa = -1;
1899 } else if ((type == scheme_case_closure_type)
1900 || (type == scheme_case_lambda_sequence_type)) {
1901 Scheme_Case_Lambda *seq;
1902 Scheme_Lambda *data;
1903 int i;
1904 Scheme_Object *mask = scheme_make_integer(0), *v;
1905
1906 seq = (Scheme_Case_Lambda *)p;
1907 for (i = 0; i < seq->count; i++) {
1908 v = seq->array[i];
1909 if ((a == -1) || (a == -3) || (a == -4)) {
1910 mask = scheme_bin_bitwise_or(get_or_check_arity(v, -4, NULL, inc_ok), mask);
1911 } else {
1912 if (SAME_TYPE(SCHEME_TYPE(v), scheme_lambda_type))
1913 data = (Scheme_Lambda *)v;
1914 else
1915 data = SCHEME_CLOSURE_CODE(v);
1916 mina = maxa = data->num_params;
1917 if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_REST) {
1918 if (mina)
1919 --mina;
1920 maxa = -1;
1921 }
1922
1923 if (a >= 0) {
1924 if ((a + drop) >= mina && (maxa < 0 || (a + drop) <= maxa))
1925 return scheme_true;
1926 } else if (a == -2) {
1927 if (maxa < 0)
1928 return scheme_true;
1929 }
1930 }
1931 }
1932
1933 if ((a == -1) || (a == -3) || (a == -4)) {
1934 if (drop)
1935 mask = shift_for_drop(mask, drop);
1936 if (a != -4)
1937 return mask_to_arity(mask, a);
1938 else
1939 return mask;
1940 } else
1941 return scheme_false;
1942 } else if (type == scheme_proc_struct_type) {
1943 int is_method;
1944 if (!inc_ok
1945 && scheme_no_arity_property
1946 && scheme_struct_type_property_ref(scheme_no_arity_property, p)) {
1947 if (a == -4)
1948 return scheme_make_integer(0);
1949 else
1950 return scheme_false;
1951 }
1952 if (scheme_reduced_procedure_struct
1953 && scheme_is_struct_instance(scheme_reduced_procedure_struct, p)) {
1954 if (a == -4) {
1955 p = ((Scheme_Structure *)p)->slots[1];
1956 if (drop)
1957 return shift_for_drop(p, drop);
1958 else
1959 return p;
1960 }
1961
1962 if (a >= 0) {
1963 bign = scheme_make_integer(a);
1964 if (drop)
1965 bign = scheme_bin_plus(bign, scheme_make_integer(drop));
1966 }
1967 if ((a == -1) || (a == -3)) {
1968 p = ((Scheme_Structure *)p)->slots[1];
1969 if (drop)
1970 p = shift_for_drop(p, drop);
1971 return mask_to_arity(p, a);
1972 } else {
1973 if (scheme_bin_bitwise_bit_set_p(((Scheme_Structure *)p)->slots[1], bign))
1974 return scheme_true;
1975 else
1976 return scheme_false;
1977 }
1978 } else {
1979 p = scheme_extract_struct_procedure(p, -1, NULL, &is_method);
1980 if (!SCHEME_PROCP(p)) {
1981 if (a == -4)
1982 return scheme_make_integer(0);
1983 else if ((a == -1) || (a == -3))
1984 return scheme_null;
1985 else
1986 return scheme_false;
1987 }
1988 if (is_method)
1989 drop++;
1990 }
1991 SCHEME_USE_FUEL(1);
1992 goto top;
1993 #ifdef MZ_USE_JIT
1994 } else if (type == scheme_native_closure_type) {
1995 if (a < 0) {
1996 Scheme_Object *pa;
1997
1998 pa = scheme_get_native_arity(p, a);
1999 if (a == -4) {
2000 if (drop)
2001 return shift_for_drop(pa, drop);
2002 else
2003 return pa;
2004 }
2005
2006 if (SCHEME_BOXP(pa)) {
2007 /* Is a method; pa already corrects for it */
2008 pa = SCHEME_BOX_VAL(pa);
2009 }
2010
2011 if (SCHEME_STRUCTP(pa)) {
2012 /* This happens when a non-case-lambda is not yet JITted.
2013 It's an arity-at-least record. Convert it to the
2014 negative-int encoding. */
2015 int v;
2016 pa = ((Scheme_Structure *)pa)->slots[0];
2017 v = -(SCHEME_INT_VAL(pa) + 1);
2018 pa = scheme_make_integer(v);
2019 }
2020
2021 if (SCHEME_INTP(pa)) {
2022 mina = SCHEME_INT_VAL(pa);
2023 if (mina < 0) {
2024 if (a == -2) {
2025 /* Yes, varargs */
2026 return scheme_true;
2027 }
2028 mina = (-mina) - 1;
2029 maxa = -1;
2030 } else {
2031 if (a == -2) {
2032 /* No varargs */
2033 return scheme_false;
2034 }
2035 maxa = mina;
2036 }
2037 } else {
2038 if (a == -2) {
2039 /* Check for varargs */
2040 Scheme_Object *a;
2041 while (!SCHEME_NULLP(pa)) {
2042 a = SCHEME_CAR(pa);
2043 if (SCHEME_STRUCTP(a))
2044 return scheme_true;
2045 pa = SCHEME_CDR(pa);
2046 }
2047 return scheme_false;
2048 } else {
2049 if (drop) {
2050 /* Need to adjust elements (e.g., because this
2051 procedure is a struct's apply handler) */
2052 Scheme_Object *first = scheme_null, *last = NULL, *ae;
2053 int v;
2054 while (SCHEME_PAIRP(pa)) {
2055 ae = SCHEME_CAR(pa);
2056 if (SCHEME_INTP(ae)) {
2057 v = SCHEME_INT_VAL(ae);
2058 if (v < drop)
2059 ae = NULL;
2060 else {
2061 v -= drop;
2062 ae = scheme_make_integer(v);
2063 }
2064 } else {
2065 /* arity-at-least */
2066 ae = ((Scheme_Structure *)ae)->slots[0];
2067 v = SCHEME_INT_VAL(ae);
2068 if (v >= drop) {
2069 ae = make_arity(v - drop, -1, a);
2070 } else {
2071 ae = make_arity(0, -1, a);
2072 }
2073 }
2074 if (ae) {
2075 ae = scheme_make_pair(ae, scheme_null);
2076 if (last)
2077 SCHEME_CDR(last) = ae;
2078 else
2079 first = ae;
2080 last = ae;
2081 }
2082 pa = SCHEME_CDR(pa);
2083 }
2084 return first;
2085 }
2086 return pa;
2087 }
2088 }
2089 } else {
2090 if (scheme_native_arity_check(p, a + drop))
2091 return scheme_true;
2092 else
2093 return scheme_false;
2094 }
2095 #endif
2096 } else if (type == scheme_proc_chaperone_type) {
2097 p = SCHEME_CHAPERONE_VAL(p);
2098 SCHEME_USE_FUEL(1);
2099 goto top;
2100 } else {
2101 Scheme_Lambda *data;
2102
2103 if (type == scheme_lambda_type)
2104 data = (Scheme_Lambda *)p;
2105 else if (type == scheme_closure_type)
2106 data = SCHEME_CLOSURE_CODE(p);
2107 else
2108 return scheme_false;
2109
2110 mina = maxa = data->num_params;
2111 if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_REST) {
2112 if (mina)
2113 --mina;
2114 maxa = -1;
2115 }
2116 }
2117
2118 if (cases) {
2119 int count = cases_count, i;
2120 if ((a == -1) || (a == -3) || (a == -4)) {
2121 /* Compute mask to get arity so that the arity is normalized */
2122 Scheme_Object *mask = scheme_make_integer(0);
2123
2124 for (i = 0; i < count; i++) {
2125 mask = scheme_bin_bitwise_or(make_arity_mask(cases[2 * i], cases[(2 * i)+1]), mask);
2126 }
2127 if (drop)
2128 mask = shift_for_drop(mask, drop);
2129
2130
2131 if (a == -4)
2132 return mask;
2133 else
2134 return mask_to_arity(mask, a);
2135 }
2136
2137 if (a == -2) {
2138 for (i = 0; i < count; i++) {
2139 if (cases[(2 * i) + 1] < 0)
2140 return scheme_true;
2141 }
2142
2143 return scheme_false;
2144 }
2145
2146 a += drop;
2147
2148 for (i = 0; i < count; i++) {
2149 int na, xa;
2150 na = cases[2 * i];
2151 xa = cases[(2 * i) + 1];
2152 if ((a >= na) && ((xa < 0) || (a <= xa)))
2153 return scheme_true;
2154 }
2155
2156 return scheme_false;
2157 }
2158
2159 if ((a == -1) || (a == -3) || (a == -4)) {
2160 if (mina < drop) {
2161 if ((maxa >= 0) && (maxa < drop)) {
2162 if (a == -4)
2163 return scheme_make_integer(0);
2164 else
2165 return scheme_null;
2166 } else
2167 mina = 0;
2168 } else
2169 mina -= drop;
2170 if (maxa > 0) {
2171 /* assert: maxa >= drop, or else would have returned in `mina < drop` test */
2172 maxa -= drop;
2173 }
2174
2175 if (a == -4)
2176 return make_arity_mask(mina, maxa);
2177
2178 return make_arity(mina, maxa, a);
2179 }
2180
2181 if (a == -2)
2182 return (maxa < 0) ? scheme_true : scheme_false;
2183
2184 a += drop;
2185
2186 if (a < mina || (maxa >= 0 && a > maxa))
2187 return scheme_false;
2188
2189 return scheme_true;
2190 }
2191
scheme_get_or_check_arity(Scheme_Object * p,intptr_t a)2192 Scheme_Object *scheme_get_or_check_arity(Scheme_Object *p, intptr_t a)
2193 {
2194 return get_or_check_arity(p, a, NULL, 1);
2195 }
2196
scheme_get_arity_mask(Scheme_Object * p)2197 Scheme_Object *scheme_get_arity_mask(Scheme_Object *p)
2198 {
2199 return get_or_check_arity(p, -4, NULL, 1);
2200 }
2201
scheme_check_proc_arity2(const char * where,int a,int which,int argc,Scheme_Object ** argv,int false_ok)2202 int scheme_check_proc_arity2(const char *where, int a,
2203 int which, int argc, Scheme_Object **argv,
2204 int false_ok)
2205 {
2206 Scheme_Object *p;
2207
2208 if (which < 0)
2209 p = argv[0];
2210 else
2211 p = argv[which];
2212
2213 if (false_ok && SCHEME_FALSEP(p))
2214 return 1;
2215
2216 if (!SCHEME_PROCP(p) || SCHEME_FALSEP(get_or_check_arity(p, a, NULL, 1))) {
2217 if (where) {
2218 char buffer[60];
2219 const char *pre, *post;
2220
2221 if (false_ok) {
2222 pre = "(or/c ";
2223 post = " #f)";
2224 } else
2225 pre = post = "";
2226
2227 switch (a) {
2228 case 0:
2229 sprintf(buffer, "%s(-> any)%s", pre, post);
2230 break;
2231 case 1:
2232 sprintf(buffer, "%s(any/c . -> . any)%s", pre, post);
2233 break;
2234 case 2:
2235 sprintf(buffer, "%s(any/c any/c . -> . any)%s", pre, post);
2236 break;
2237 case 3:
2238 sprintf(buffer, "%s(any/c any/c any/c . -> . any)%s", pre, post);
2239 break;
2240 default:
2241 sprintf(buffer, "%s(procedure-arity-includes/c %d)%s",
2242 pre, a, post);
2243 break;
2244 }
2245
2246 scheme_wrong_contract(where, buffer, which, argc, argv);
2247 } else
2248 return 0;
2249 }
2250
2251 return 1;
2252 }
2253
scheme_check_proc_arity(const char * where,int a,int which,int argc,Scheme_Object ** argv)2254 int scheme_check_proc_arity(const char *where, int a,
2255 int which, int argc, Scheme_Object **argv)
2256 {
2257 return scheme_check_proc_arity2(where, a, which, argc, argv, 0);
2258 }
2259
scheme_closure_preserves_marks(Scheme_Object * p)2260 int scheme_closure_preserves_marks(Scheme_Object *p)
2261 {
2262 Scheme_Type type = SCHEME_TYPE(p);
2263 Scheme_Lambda *data;
2264
2265 #ifdef MZ_USE_JIT
2266 if (type == scheme_native_closure_type)
2267 return scheme_native_closure_preserves_marks(p);
2268 #endif
2269
2270 if (type == scheme_closure_type) {
2271 data = SCHEME_CLOSURE_CODE(p);
2272 } else if (type == scheme_lambda_type) {
2273 data = (Scheme_Lambda *)p;
2274 } else
2275 return 0;
2276
2277 if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_PRESERVES_MARKS)
2278 return 1;
2279
2280 return 0;
2281 }
2282
scheme_get_or_check_procedure_shape(Scheme_Object * e,Scheme_Object * expected,int imprecise)2283 Scheme_Object *scheme_get_or_check_procedure_shape(Scheme_Object *e, Scheme_Object *expected, int imprecise)
2284 /* result is interned --- a symbol or fixnum */
2285 {
2286 Scheme_Object *p;
2287
2288 if (expected
2289 && SCHEME_SYMBOLP(expected)) {
2290 if (SCHEME_SYM_VAL(expected)[0] == 's') {
2291 return (scheme_get_or_check_structure_shape(e, expected)
2292 ? expected
2293 : NULL);
2294 } else if (SCHEME_SYM_VAL(expected)[0] == 'p') {
2295 return (scheme_get_or_check_structure_property_shape(e, expected)
2296 ? expected
2297 : NULL);
2298 }
2299 }
2300
2301 if (SAME_TYPE(SCHEME_TYPE(e), scheme_inline_variant_type))
2302 e = SCHEME_VEC_ELS(e)[1];
2303
2304 if (!SCHEME_PROCP(e) && (SCHEME_TYPE(e) >= _scheme_ir_values_types_))
2305 return NULL;
2306
2307 p = scheme_get_or_check_arity(e, -3);
2308 if (SCHEME_FALSEP(p))
2309 return NULL;
2310
2311 if (SCHEME_PAIRP(p)) {
2312 /* encode as a symbol */
2313 int sz = 32, c = 0;
2314 char *b, *naya;
2315 b = (char *)scheme_malloc_atomic(sz);
2316
2317 while (SCHEME_PAIRP(p)) {
2318 if (sz - c < 10) {
2319 sz *= 2;
2320 naya = (char *)scheme_malloc_atomic(sz);
2321 memcpy(naya, b, c);
2322 b = naya;
2323 }
2324 if (c)
2325 b[c++] = ':';
2326 c += sprintf(b XFORM_OK_PLUS c, "%" PRIdPTR, SCHEME_INT_VAL(SCHEME_CAR(p)));
2327
2328 p = SCHEME_CDR(p);
2329 }
2330 b[c] = c;
2331 p = scheme_intern_exact_symbol(b, c);
2332 } else {
2333 /* Integer encoding, but shift to use low bit to indicate whether
2334 it preserves marks, which is useful information for the JIT. */
2335 intptr_t i = SCHEME_INT_VAL(p);
2336 i = ((uintptr_t)i) << 1;
2337 if (expected && SCHEME_INTP(expected) && !(SCHEME_INT_VAL(expected) & 0x1)) {
2338 /* It's ok for an `e` that preserves marks to match an
2339 expectation of not preserving marks */
2340 } else {
2341 if (!imprecise && scheme_closure_preserves_marks(e)) {
2342 i |= 0x1;
2343 }
2344 }
2345 p = scheme_make_integer(i);
2346 }
2347
2348 if (expected && !SAME_OBJ(expected, p))
2349 return NULL;
2350
2351 return p;
2352 }
2353
2354 /*========================================================================*/
2355 /* basic function primitives */
2356 /*========================================================================*/
2357
2358 static Scheme_Object *
void_func(int argc,Scheme_Object * argv[])2359 void_func (int argc, Scheme_Object *argv[])
2360 {
2361 return scheme_void;
2362 }
2363
2364 static Scheme_Object *
void_p(int argc,Scheme_Object * argv[])2365 void_p (int argc, Scheme_Object *argv[])
2366 {
2367 return SAME_OBJ(argv[0], scheme_void) ? scheme_true : scheme_false;
2368 }
2369
2370 Scheme_Object *
scheme_check_not_undefined(int argc,Scheme_Object * argv[])2371 scheme_check_not_undefined (int argc, Scheme_Object *argv[])
2372 {
2373 if (!SCHEME_SYMBOLP(argv[1]))
2374 scheme_wrong_contract("check-not-unsafe-undefined", "symbol?", 1, argc, argv);
2375
2376 if (SAME_OBJ(argv[0], scheme_undefined)) {
2377 scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE,
2378 argv[1],
2379 "%S: undefined;\n cannot use before initialization",
2380 argv[1]);
2381 }
2382
2383 return argv[0];
2384 }
2385
2386 Scheme_Object *
scheme_check_assign_not_undefined(int argc,Scheme_Object * argv[])2387 scheme_check_assign_not_undefined (int argc, Scheme_Object *argv[])
2388 {
2389 if (!SCHEME_SYMBOLP(argv[1]))
2390 scheme_wrong_contract("check-not-unsafe-undefined/assign", "symbol?", 1, argc, argv);
2391
2392 if (SAME_OBJ(argv[0], scheme_undefined)) {
2393 scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE,
2394 argv[1],
2395 "%S: assignment disallowed;\n cannot assign before initialization",
2396 argv[1]);
2397 }
2398
2399 return argv[0];
2400 }
2401
chaperone_unsafe_undefined(int argc,Scheme_Object ** argv)2402 static Scheme_Object *chaperone_unsafe_undefined(int argc, Scheme_Object **argv)
2403 {
2404 if (SCHEME_CHAPERONE_STRUCTP(argv[0]))
2405 return scheme_chaperone_not_undefined(argv[0]);
2406 else
2407 return argv[0];
2408 }
2409
2410 static Scheme_Object *
procedure_p(int argc,Scheme_Object * argv[])2411 procedure_p (int argc, Scheme_Object *argv[])
2412 {
2413 return (SCHEME_PROCP(argv[0]) ? scheme_true : scheme_false);
2414 }
2415
primitive_p(int argc,Scheme_Object * argv[])2416 static Scheme_Object *primitive_p(int argc, Scheme_Object *argv[])
2417 {
2418 int isprim;
2419
2420 if (SCHEME_PRIMP(argv[0]))
2421 isprim = (((Scheme_Primitive_Proc *)argv[0])->pp.flags & SCHEME_PRIM_IS_PRIMITIVE);
2422 else if (SCHEME_CLSD_PRIMP(argv[0]))
2423 isprim = (((Scheme_Closed_Primitive_Proc *)argv[0])->pp.flags & SCHEME_PRIM_IS_PRIMITIVE);
2424 else
2425 isprim = 0;
2426
2427 return isprim ? scheme_true : scheme_false;
2428 }
2429
primitive_closure_p(int argc,Scheme_Object * argv[])2430 static Scheme_Object *primitive_closure_p(int argc, Scheme_Object *argv[])
2431 {
2432 int isprim;
2433
2434 if (SCHEME_CLSD_PRIMP(argv[0]))
2435 isprim = (((Scheme_Closed_Primitive_Proc *)argv[0])->pp.flags & SCHEME_PRIM_IS_PRIMITIVE);
2436 else
2437 isprim = 0;
2438
2439 return isprim ? scheme_true : scheme_false;
2440 }
2441
scheme_proc_struct_name_source(Scheme_Object * a)2442 Scheme_Object *scheme_proc_struct_name_source(Scheme_Object *a)
2443 {
2444 Scheme_Object *b;
2445
2446 while (SCHEME_CHAPERONE_PROC_STRUCTP(a)) {
2447 if (SCHEME_CHAPERONEP(a))
2448 a = SCHEME_CHAPERONE_VAL(a);
2449 if (scheme_object_name_property
2450 && scheme_struct_type_property_ref(scheme_object_name_property, a)) {
2451 return a;
2452 } else if (scheme_reduced_procedure_struct
2453 && scheme_is_struct_instance(scheme_reduced_procedure_struct, a)
2454 && SCHEME_TRUEP(((Scheme_Structure *)a)->slots[2])) {
2455 return a;
2456 } else {
2457 /* Either use struct name, or extract proc, depending
2458 whether it's method-style */
2459 int is_method;
2460 b = scheme_extract_struct_procedure(a, -1, NULL, &is_method);
2461 if (!is_method && SCHEME_PROCP(b)) {
2462 a = b;
2463 SCHEME_USE_FUEL(1);
2464 } else
2465 break;
2466 }
2467 }
2468
2469 return a;
2470 }
2471
scheme_get_proc_name(Scheme_Object * p,int * len,int for_error)2472 const char *scheme_get_proc_name(Scheme_Object *p, int *len, int for_error)
2473 /* for_error > 0 => get name for an error message;
2474 for_error < 0 => symbol result ok set *len to -1 */
2475 {
2476 Scheme_Type type;
2477 int dummy;
2478 char *s;
2479
2480 if (!len)
2481 len = &dummy;
2482
2483 top:
2484
2485 type = SCHEME_TYPE(p);
2486 if (type == scheme_prim_type) {
2487 if (((Scheme_Primitive_Proc *)p)->name)
2488 *len = strlen(((Scheme_Primitive_Proc *)p)->name);
2489 return ((Scheme_Primitive_Proc *)p)->name;
2490 } else if (type == scheme_closed_prim_type) {
2491 if (((Scheme_Closed_Primitive_Proc *)p)->name)
2492 *len = strlen(((Scheme_Closed_Primitive_Proc *)p)->name);
2493 return ((Scheme_Closed_Primitive_Proc *)p)->name;
2494 } else if (type == scheme_cont_type || type == scheme_escaping_cont_type) {
2495 return NULL;
2496 } else if (type == scheme_case_closure_type) {
2497 Scheme_Object *n;
2498
2499 n = ((Scheme_Case_Lambda *)p)->name;
2500 if (n) {
2501 if (SCHEME_BOXP(n)) {
2502 /* See note in schpriv.h about the IS_METHOD hack */
2503 n = SCHEME_BOX_VAL(n);
2504 if (SCHEME_FALSEP(n))
2505 return NULL;
2506 }
2507
2508 if (SCHEME_VECTORP(n))
2509 n = SCHEME_VEC_ELS(n)[0];
2510
2511 if (for_error < 0) {
2512 s = (char *)n;
2513 *len = -1;
2514 } else {
2515 *len = SCHEME_SYM_LEN(n);
2516 s = scheme_symbol_val(n);
2517 }
2518 } else
2519 return NULL;
2520 } else if (type == scheme_proc_struct_type) {
2521 /* Assert: the request is for an error. */
2522 Scheme_Object *other;
2523 other = scheme_proc_struct_name_source(p);
2524 if (SAME_OBJ(other, p)) {
2525 if (scheme_reduced_procedure_struct
2526 && scheme_is_struct_instance(scheme_reduced_procedure_struct, p)) {
2527 /* It must have a name: */
2528 Scheme_Object *sym = ((Scheme_Structure *)p)->slots[2];
2529 if (for_error < 0) {
2530 s = (char *)sym;
2531 *len = -1;
2532 } else {
2533 *len = SCHEME_SYM_LEN(sym);
2534 s = scheme_symbol_val(sym);
2535 }
2536 } else {
2537 Scheme_Object *sym;
2538 intptr_t offset;
2539 sym = SCHEME_STRUCT_NAME_SYM(p);
2540 *len = SCHEME_SYM_LEN(sym);
2541 s = (char *)scheme_malloc_atomic((*len) + 8);
2542 if (0) {
2543 memcpy(s, "struct ", 7);
2544 offset = 7;
2545 } else
2546 offset = 0;
2547 memcpy(s + offset, scheme_symbol_val(sym), *len);
2548 (*len) += offset;
2549 s[*len] = 0;
2550 return s;
2551 }
2552 } else {
2553 p = other;
2554 goto top;
2555 }
2556 } else if (type == scheme_proc_chaperone_type) {
2557 p = SCHEME_CHAPERONE_VAL(p);
2558 SCHEME_USE_FUEL(1);
2559 goto top;
2560 } else {
2561 Scheme_Object *name;
2562
2563 if ((type == scheme_ir_lambda_type)
2564 || (type == scheme_lambda_type)) {
2565 name = ((Scheme_Lambda *)p)->name;
2566 } else if (type == scheme_closure_type) {
2567 name = SCHEME_CLOSURE_CODE(p)->name;
2568 } else if (type == scheme_case_lambda_sequence_type) {
2569 Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)p;
2570 if (!cl->count)
2571 name = NULL;
2572 else
2573 name = ((Scheme_Lambda *)cl->array[0])->name;
2574 } else {
2575 /* Native closure: */
2576 name = ((Scheme_Native_Closure *)p)->code->u2.name;
2577 if (name && SAME_TYPE(SCHEME_TYPE(name), scheme_lambda_type)) {
2578 /* Not yet jitted. Use `name' as the other alternative of
2579 the union: */
2580 name = ((Scheme_Lambda *)name)->name;
2581 }
2582 }
2583
2584 if (name) {
2585 if (SCHEME_VECTORP(name))
2586 name = SCHEME_VEC_ELS(name)[0];
2587 if (for_error < 0) {
2588 s = (char *)name;
2589 *len = -1;
2590 } else {
2591 *len = SCHEME_SYM_LEN(name);
2592 s = scheme_symbol_val(name);
2593 }
2594 } else
2595 return NULL;
2596 }
2597
2598 if (0) {
2599 char *r;
2600
2601 r = (char *)scheme_malloc_atomic((*len) + 11);
2602 memcpy(r, "procedure ", 10);
2603 memcpy(r + 10, s, *len + 1);
2604 *len += 10;
2605
2606 return r;
2607 }
2608
2609 return s;
2610 }
2611
primitive_result_arity(int argc,Scheme_Object * argv[])2612 static Scheme_Object *primitive_result_arity(int argc, Scheme_Object *argv[])
2613 {
2614 Scheme_Object *o;
2615
2616 o = argv[0];
2617
2618 if (SCHEME_PRIMP(o)
2619 && (((Scheme_Primitive_Proc *)o)->pp.flags & SCHEME_PRIM_IS_PRIMITIVE)) {
2620 if (((Scheme_Primitive_Proc *)o)->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT) {
2621 Scheme_Prim_W_Result_Arity *p = (Scheme_Prim_W_Result_Arity *)o;
2622 return scheme_make_arity(p->minr, p->maxr);
2623 }
2624 } else if (SCHEME_CLSD_PRIMP(o)
2625 && (((Scheme_Closed_Primitive_Proc *)o)->pp.flags & SCHEME_PRIM_IS_PRIMITIVE)) {
2626 if (((Scheme_Closed_Primitive_Proc *)o)->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT) {
2627 Scheme_Closed_Prim_W_Result_Arity *p = (Scheme_Closed_Prim_W_Result_Arity *)o;
2628 return scheme_make_arity(p->minr, p->maxr);
2629 }
2630 } else {
2631 scheme_wrong_contract("primitive-result-arity", "primitive?", 0, argc, argv);
2632 return NULL;
2633 }
2634 return scheme_make_integer(1);
2635 }
2636
procedure_result_arity(int argc,Scheme_Object * argv[])2637 static Scheme_Object *procedure_result_arity(int argc, Scheme_Object *argv[])
2638 {
2639 Scheme_Object *o, *orig_o;
2640
2641 orig_o = argv[0];
2642 o = orig_o;
2643
2644 if (SCHEME_CHAPERONEP(o))
2645 o = SCHEME_CHAPERONE_VAL(o);
2646
2647 /* Struct procedures could be keyword-accepting and that
2648 requires additional complication; defer for now */
2649 if (SAME_TYPE(SCHEME_TYPE(o), scheme_proc_struct_type)
2650 /* Structs corresponding to reduced-arity procedures are ok, though.
2651 Their result arity is just that of the underlying procedure. */
2652 && !scheme_is_struct_instance(scheme_reduced_procedure_struct, o)) {
2653 return scheme_false;
2654 }
2655
2656 if (SAME_TYPE(SCHEME_TYPE(o), scheme_closure_type)) {
2657 if ((SCHEME_LAMBDA_FLAGS(SCHEME_CLOSURE_CODE(o)) & LAMBDA_SINGLE_RESULT)) {
2658 return scheme_make_integer(1);
2659 }
2660 #ifdef MZ_USE_JIT
2661 } else if (SAME_TYPE(SCHEME_TYPE(o), scheme_native_closure_type)) {
2662 if (scheme_native_closure_is_single_result(o))
2663 return scheme_make_integer(1);
2664 #endif
2665 } else if (SAME_TYPE(SCHEME_TYPE(o), scheme_case_closure_type)) {
2666 Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)o;
2667 int i;
2668
2669 for (i = cl->count; i--; ) {
2670 if (!(SCHEME_LAMBDA_FLAGS(SCHEME_CLOSURE_CODE(cl->array[i])) & LAMBDA_SINGLE_RESULT))
2671 break;
2672 }
2673
2674 if (i < 0)
2675 return scheme_make_integer(1);
2676 } else if (SCHEME_PRIMP(o)) {
2677 if (((Scheme_Primitive_Proc *)o)->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT) {
2678 Scheme_Prim_W_Result_Arity *p = (Scheme_Prim_W_Result_Arity *)o;
2679 return scheme_make_arity(p->minr, p->maxr);
2680 }
2681 return scheme_make_integer(1);
2682 } else if (SCHEME_STRUCTP(o)
2683 && scheme_is_struct_instance(scheme_reduced_procedure_struct, o)) {
2684 return procedure_result_arity(1, &((Scheme_Structure *)o)->slots[0]);
2685 } else if (!SCHEME_PROCP(o)) {
2686 scheme_wrong_contract("procedure-result-arity", "procedure?", 0, argc, argv);
2687 return NULL;
2688 }
2689 return scheme_false;
2690 }
2691
scheme_object_name(Scheme_Object * a)2692 Scheme_Object *scheme_object_name(Scheme_Object *a)
2693 {
2694 Scheme_Object *v;
2695
2696 v = scheme_struct_type_property_ref(scheme_object_name_property, a);
2697
2698 if (v) {
2699 if (SCHEME_INTP(v))
2700 return scheme_struct_ref(a, SCHEME_INT_VAL(v));
2701 if (SCHEME_PROCP(v)) {
2702 if (scheme_check_proc_arity(NULL, 1, 0, 1, &v)) {
2703 Scheme_Object *f = v, *arg[1];
2704
2705 arg[0] = a;
2706 return scheme_apply(f, 1, arg);
2707 }
2708 }
2709 }
2710
2711 if (SCHEME_CHAPERONEP(a))
2712 a = SCHEME_CHAPERONE_VAL(a);
2713
2714 if (SCHEME_PROC_STRUCTP(a)) {
2715 a = scheme_proc_struct_name_source(a);
2716 if (SCHEME_CHAPERONEP(a))
2717 a = SCHEME_CHAPERONE_VAL(a);
2718
2719 if (SCHEME_STRUCTP(a)
2720 && scheme_reduced_procedure_struct
2721 && scheme_is_struct_instance(scheme_reduced_procedure_struct, a)) {
2722 /* It must have a name: */
2723 return ((Scheme_Structure *)a)->slots[2];
2724 }
2725 }
2726
2727 if (SCHEME_STRUCTP(a)) {
2728 if (!(SCHEME_STRUCT_TYPE(a)->more_flags & STRUCT_TYPE_FLAG_SYSTEM_OPAQUE))
2729 return SCHEME_STRUCT_NAME_SYM(a);
2730 } else if (SCHEME_PROCP(a)) {
2731 const char *s;
2732 int len;
2733
2734 s = scheme_get_proc_name(a, &len, -1);
2735 if (s) {
2736 if (len < 0)
2737 return (Scheme_Object *)s;
2738 else
2739 return scheme_intern_exact_symbol(s, len);
2740 }
2741 } else if (SCHEME_STRUCT_TYPEP(a)) {
2742 return ((Scheme_Struct_Type *)a)->name;
2743 } else if (SAME_TYPE(SCHEME_TYPE(a), scheme_struct_property_type)) {
2744 return ((Scheme_Struct_Property *)a)->name;
2745 } else if (SAME_TYPE(SCHEME_TYPE(a), scheme_regexp_type)) {
2746 Scheme_Object *s;
2747 s = scheme_regexp_source(a);
2748 if (s)
2749 return s;
2750 } else if (SCHEME_INPUT_PORTP(a)) {
2751 Scheme_Input_Port *ip;
2752 ip = scheme_input_port_record(a);
2753 return ip->name;
2754 } else if (SCHEME_OUTPUT_PORTP(a)) {
2755 Scheme_Output_Port *op;
2756 op = scheme_output_port_record(a);
2757 return op->name;
2758 } else if (SCHEME_THREADP(a)) {
2759 Scheme_Thread *t = (Scheme_Thread *)a;
2760 if (t->name) {
2761 return t->name;
2762 }
2763 } else if (SAME_TYPE(SCHEME_TYPE(a), scheme_logger_type)) {
2764 Scheme_Logger *logger = (Scheme_Logger *)a;
2765 if (logger->name)
2766 return logger->name;
2767 } else if (SCHEME_PROMPT_TAGP(a)) {
2768 /* See make_prompt_tag for the structure of continuation prompt tags. */
2769 if (SCHEME_CDR(a))
2770 return SCHEME_CDR(a);
2771 }
2772
2773 return scheme_false;
2774 }
2775
object_name(int argc,Scheme_Object ** argv)2776 static Scheme_Object *object_name(int argc, Scheme_Object **argv)
2777 {
2778 return scheme_object_name(argv[0]);
2779 }
2780
scheme_arity(Scheme_Object * p)2781 Scheme_Object *scheme_arity(Scheme_Object *p)
2782 {
2783 return get_or_check_arity(p, -1, NULL, 1);
2784 }
2785
procedure_arity(int argc,Scheme_Object * argv[])2786 static Scheme_Object *procedure_arity(int argc, Scheme_Object *argv[])
2787 {
2788 if (!SCHEME_PROCP(argv[0]))
2789 scheme_wrong_contract("procedure-arity", "procedure?", 0, argc, argv);
2790
2791 return get_or_check_arity(argv[0], -1, NULL, 1);
2792 }
2793
procedure_arity_mask(int argc,Scheme_Object * argv[])2794 static Scheme_Object *procedure_arity_mask(int argc, Scheme_Object *argv[])
2795 {
2796 if (!SCHEME_PROCP(argv[0]))
2797 scheme_wrong_contract("procedure-arity-mask", "procedure?", 0, argc, argv);
2798
2799 return get_or_check_arity(argv[0], -4, NULL, 1);
2800 }
2801
procedure_arity_p(int argc,Scheme_Object * argv[])2802 static Scheme_Object *procedure_arity_p(int argc, Scheme_Object *argv[])
2803 {
2804 Scheme_Object *a = argv[0], *v;
2805
2806 if (SCHEME_INTP(a)) {
2807 return ((SCHEME_INT_VAL(a) >= 0) ? scheme_true : scheme_false);
2808 } else if (SCHEME_BIGNUMP(a)) {
2809 return (SCHEME_BIGPOS(a) ? scheme_true : scheme_false);
2810 } else if (SCHEME_NULLP(a)) {
2811 return scheme_true;
2812 } else if (SCHEME_PAIRP(a)) {
2813 while (SCHEME_PAIRP(a)) {
2814 v = SCHEME_CAR(a);
2815 if (SCHEME_INTP(v)) {
2816 if (SCHEME_INT_VAL(v) < 0)
2817 return scheme_false;
2818 } else if (SCHEME_BIGNUMP(v)) {
2819 if (!SCHEME_BIGPOS(v))
2820 return scheme_false;
2821 } else if (!SCHEME_CHAPERONE_STRUCTP(v)
2822 || !scheme_is_struct_instance(scheme_arity_at_least, v)) {
2823 return scheme_false;
2824 }
2825 a = SCHEME_CDR(a);
2826 }
2827 return SCHEME_NULLP(a) ? scheme_true : scheme_false;
2828 } else if (SCHEME_CHAPERONE_STRUCTP(a)
2829 && scheme_is_struct_instance(scheme_arity_at_least, a)) {
2830 return scheme_true;
2831 } else
2832 return scheme_false;
2833 }
2834
scheme_procedure_arity_includes(int argc,Scheme_Object * argv[])2835 Scheme_Object *scheme_procedure_arity_includes(int argc, Scheme_Object *argv[])
2836 {
2837 intptr_t n;
2838 int inc_ok;
2839
2840 if (!SCHEME_PROCP(argv[0]))
2841 scheme_wrong_contract("procedure-arity-includes?", "procedure?", 0, argc, argv);
2842
2843 n = scheme_extract_index("procedure-arity-includes?", 1, argc, argv, -2, 0);
2844 /* -2 means a bignum */
2845
2846 inc_ok = ((argc > 2) && SCHEME_TRUEP(argv[2]));
2847
2848 return get_or_check_arity(argv[0], n, argv[1], inc_ok);
2849 }
2850
is_arity(Scheme_Object * a,int at_least_ok,int list_ok)2851 static int is_arity(Scheme_Object *a, int at_least_ok, int list_ok)
2852 {
2853 if (SCHEME_INTP(a)) {
2854 return (SCHEME_INT_VAL(a) >= 0);
2855 } else if (SCHEME_BIGNUMP(a)) {
2856 return SCHEME_BIGPOS(a);
2857 } else if (at_least_ok
2858 && SCHEME_CHAPERONE_STRUCTP(a)
2859 && scheme_is_struct_instance(scheme_arity_at_least, a)) {
2860 a = scheme_struct_ref(a, 0);
2861 return is_arity(a, 0, 0);
2862 }
2863
2864 if (!list_ok)
2865 return 0;
2866
2867 while (SCHEME_PAIRP(a)) {
2868 if (!is_arity(SCHEME_CAR(a), 1, 0))
2869 return 0;
2870 a = SCHEME_CDR(a);
2871 }
2872
2873 if (SCHEME_NULLP(a))
2874 return 1;
2875 return 0;
2876 }
2877
scheme_init_reduced_proc_struct(Scheme_Startup_Env * env)2878 void scheme_init_reduced_proc_struct(Scheme_Startup_Env *env)
2879 {
2880 if (!scheme_reduced_procedure_struct) {
2881 Scheme_Inspector *insp;
2882
2883 REGISTER_SO(scheme_reduced_procedure_struct);
2884 insp = (Scheme_Inspector *) scheme_get_current_inspector();
2885 while (insp->superior->superior) {
2886 insp = insp->superior;
2887 }
2888 scheme_reduced_procedure_struct = scheme_make_struct_type2(scheme_intern_symbol("procedure"),
2889 NULL,
2890 (Scheme_Object *)insp,
2891 4, 0,
2892 scheme_false,
2893 scheme_null,
2894 scheme_make_integer(0),
2895 NULL, NULL);
2896 }
2897 }
2898
arity_to_mask(Scheme_Object * aty)2899 static Scheme_Object *arity_to_mask(Scheme_Object *aty)
2900 {
2901 if (SCHEME_INTP(aty)) {
2902 intptr_t n = SCHEME_INT_VAL(aty);
2903 if (n <= SCHEME_MAX_FAST_ARITY_CHECK)
2904 return scheme_make_integer(1 << n);
2905 else
2906 return make_shifted_one(n);
2907 } else if (SCHEME_BIGNUMP(aty)) {
2908 scheme_raise_out_of_memory(NULL, NULL);
2909 return NULL;
2910 } else if (SCHEME_STRUCTP(aty)) {
2911 Scheme_Object *mask;
2912
2913 aty = scheme_struct_ref(aty, 0);
2914 if (SCHEME_INTP(aty))
2915 return make_arity_mask(SCHEME_INT_VAL(aty), -1);
2916 else {
2917 mask = arity_to_mask(aty);
2918 return scheme_bin_bitwise_xor(scheme_bin_minus(mask, scheme_make_integer(1)),
2919 scheme_make_integer(-1));
2920 }
2921 } else if (SCHEME_PAIRP(aty)) {
2922 Scheme_Object *mask = scheme_make_integer(0);
2923 while (SCHEME_PAIRP(aty)) {
2924 mask = scheme_bin_bitwise_or(arity_to_mask(SCHEME_CAR(aty)), mask);
2925 aty = SCHEME_CDR(aty);
2926 }
2927 return mask;
2928 } else
2929 return scheme_make_integer(0);
2930 }
2931
mask_to_arity(Scheme_Object * mask,int mode)2932 static Scheme_Object *mask_to_arity(Scheme_Object *mask, int mode)
2933 {
2934 intptr_t n, pos = 0;
2935 Scheme_Object *l = scheme_null;
2936
2937 while (!SCHEME_INTP(mask)) {
2938 Scheme_Object *a[2], *b;
2939 b = scheme_bin_bitwise_and(mask, scheme_make_integer(0xFFFF));
2940 if (SCHEME_INTP(b)) {
2941 b = scheme_bin_bitwise_and(mask, scheme_make_integer(1));
2942 if (SCHEME_INTP(b))
2943 l = scheme_make_pair(scheme_make_integer(pos), l);
2944 pos++;
2945 a[0] = mask;
2946 a[1] = scheme_make_integer(-1);
2947 mask = scheme_bitwise_shift(2, a);
2948 } else {
2949 pos += 16;
2950 a[0] = mask;
2951 a[1] = scheme_make_integer(-16);
2952 mask = scheme_bitwise_shift(2, a);
2953 }
2954 }
2955
2956 n = SCHEME_INT_VAL(mask);
2957 if (!n) {
2958 if (SCHEME_PAIRP(l) && SCHEME_NULLP(SCHEME_CDR(l)))
2959 return SCHEME_CAR(l);
2960 else
2961 return scheme_reverse(l);
2962 }
2963
2964 while (1) {
2965 if (n == -1) {
2966 if (SCHEME_NULLP(l))
2967 return make_arity(pos, -1, mode);
2968 else
2969 return scheme_reverse(scheme_make_pair(make_arity(pos, -1, mode), l));
2970 } else if (n == 1) {
2971 if (SCHEME_NULLP(l))
2972 return scheme_make_integer(pos);
2973 else
2974 return scheme_reverse(scheme_make_pair(scheme_make_integer(pos), l));
2975 } else if (n & 0x1) {
2976 l = scheme_make_pair(scheme_make_integer(pos), l);
2977 }
2978 pos++;
2979 n >>= 1;
2980 }
2981 }
2982
scheme_arity_mask_to_arity(Scheme_Object * mask,int mode)2983 Scheme_Object *scheme_arity_mask_to_arity(Scheme_Object *mask, int mode)
2984 {
2985 return mask_to_arity(mask, mode);
2986 }
2987
make_reduced_proc(Scheme_Object * proc,Scheme_Object * mask,Scheme_Object * name,Scheme_Object * is_meth)2988 static Scheme_Object *make_reduced_proc(Scheme_Object *proc,
2989 Scheme_Object *mask,
2990 Scheme_Object *name, Scheme_Object *is_meth)
2991 {
2992 Scheme_Structure *inst;
2993
2994 if (SCHEME_STRUCTP(proc)
2995 && scheme_is_struct_instance(scheme_reduced_procedure_struct, proc)) {
2996 /* Don't need the intermediate layer */
2997 if (!name)
2998 name = ((Scheme_Structure *)proc)->slots[2];
2999 if (!is_meth)
3000 is_meth = ((Scheme_Structure *)proc)->slots[3];
3001 proc = ((Scheme_Structure *)proc)->slots[0];
3002 }
3003
3004 inst = (Scheme_Structure *)scheme_malloc_tagged(sizeof(Scheme_Structure)
3005 + ((4 - mzFLEX_DELTA) * sizeof(Scheme_Object *)));
3006 inst->so.type = scheme_proc_struct_type;
3007 inst->stype = (Scheme_Struct_Type *)scheme_reduced_procedure_struct;
3008
3009 inst->slots[0] = proc;
3010 inst->slots[1] = mask;
3011 inst->slots[2] = (name ? name : scheme_false);
3012 inst->slots[3] = (is_meth ? is_meth : scheme_false);
3013
3014 return (Scheme_Object *)inst;
3015 }
3016
is_subarity(Scheme_Object * req,Scheme_Object * orig,int req_delta)3017 static int is_subarity(Scheme_Object *req, Scheme_Object *orig, int req_delta)
3018 {
3019 Scheme_Object *oa, *ra, *ol, *lra, *ara, *prev, *pr, *tmp, *rd;
3020
3021 if (!SCHEME_PAIRP(orig) && !SCHEME_NULLP(orig))
3022 orig = scheme_make_pair(orig, scheme_null);
3023 if (!SCHEME_PAIRP(req) && !SCHEME_NULLP(req))
3024 req = scheme_make_pair(req, scheme_null);
3025
3026 rd = scheme_make_integer(req_delta);
3027
3028 while (!SCHEME_NULLP(req)) {
3029 ra = SCHEME_CAR(req);
3030 if (SCHEME_CHAPERONE_STRUCTP(ra)
3031 && scheme_is_struct_instance(scheme_arity_at_least, ra)) {
3032 /* Convert to a sequence of range pairs, where the
3033 last one can be (min, #f); we'll iterate through the
3034 original arity to knock out ranges until (if it matches)
3035 we end up with an empty list of ranges. */
3036 ra = scheme_make_pair(scheme_make_pair(scheme_struct_ref(ra, 0),
3037 scheme_false),
3038 scheme_null);
3039 }
3040
3041 for (ol = orig; !SCHEME_NULLP(ol); ol = SCHEME_CDR(ol)) {
3042 oa = SCHEME_CAR(ol);
3043 if (SCHEME_INTP(ra) || SCHEME_BIGNUMP(ra)) {
3044 if (SCHEME_INTP(oa) || SCHEME_BIGNUMP(oa)) {
3045 if (scheme_equal(scheme_bin_plus(ra, rd), oa))
3046 break;
3047 } else {
3048 /* orig is arity-at-least */
3049 oa = ((Scheme_Structure *)oa)->slots[0];
3050 if (scheme_bin_lt_eq(oa, scheme_bin_plus(ra, rd)))
3051 break;
3052 }
3053 } else {
3054 /* requested is arity-at-least */
3055 int at_least;
3056 if (SCHEME_INTP(oa) || SCHEME_BIGNUMP(oa)) {
3057 at_least = 0;
3058 } else {
3059 /* orig is arity-at-least */
3060 at_least = 1;
3061 oa = ((Scheme_Structure *)oa)->slots[0];
3062 }
3063
3064 lra = ra;
3065 prev = NULL;
3066 while (!SCHEME_NULLP(lra)) {
3067 /* check [lo, hi] vs oa: */
3068 ara = SCHEME_CAR(lra);
3069 if (SCHEME_FALSEP(SCHEME_CDR(ara))
3070 || scheme_bin_lt_eq(oa, scheme_bin_plus(SCHEME_CDR(ara), rd))) {
3071 if (scheme_bin_gt_eq(oa, scheme_bin_plus(SCHEME_CAR(ara), rd))) {
3072 /* oa is in the range [lo, hi]: */
3073 if (scheme_equal(oa, scheme_bin_plus(SCHEME_CAR(ara), rd))) {
3074 /* the range is [oa, hi] */
3075 if (at_least) {
3076 /* oa is arity-at least, so drop from here */
3077 if (prev)
3078 SCHEME_CDR(prev) = scheme_null;
3079 else
3080 ra = scheme_null;
3081 } else {
3082 if (scheme_equal(oa, scheme_bin_plus(SCHEME_CDR(ara), rd))) {
3083 /* the range is [oa, oa], so drop it */
3084 if (prev)
3085 SCHEME_CDR(prev) = SCHEME_CDR(lra);
3086 else
3087 ra = SCHEME_CDR(lra);
3088 } else {
3089 /* change range to [ao+1, hi] */
3090 tmp = scheme_bin_plus(oa, scheme_make_integer(1));
3091 tmp = scheme_bin_minus(tmp, rd);
3092 SCHEME_CAR(ara) = tmp;
3093 }
3094 }
3095 } else if (scheme_equal(oa, scheme_bin_plus(SCHEME_CAR(ara), rd))) {
3096 /* the range is [lo, oa], where lo < oa */
3097 tmp = scheme_bin_minus(oa, scheme_make_integer(1));
3098 tmp = scheme_bin_minus(tmp, rd);
3099 SCHEME_CDR(ara) = tmp;
3100 if (at_least)
3101 SCHEME_CDR(lra) = scheme_null;
3102 } else {
3103 /* split the range */
3104 if (at_least) {
3105 tmp = scheme_bin_minus(oa, scheme_make_integer(1));
3106 tmp = scheme_bin_minus(tmp, rd);
3107 SCHEME_CDR(ara) = tmp;
3108 SCHEME_CDR(lra) = scheme_null;
3109 } else {
3110 tmp = scheme_bin_plus(oa, scheme_make_integer(1));
3111 tmp = scheme_bin_minus(tmp, rd);
3112 pr = scheme_make_pair(scheme_make_pair(tmp, SCHEME_CDR(ara)),
3113 SCHEME_CDR(lra));
3114 tmp = scheme_bin_minus(oa, scheme_make_integer(1));
3115 tmp = scheme_bin_minus(tmp, rd);
3116 SCHEME_CDR(ara) = tmp;
3117 SCHEME_CDR(lra) = pr;
3118 }
3119 }
3120 break;
3121 } else if (at_least) {
3122 /* oa is less than lo, so truncate */
3123 if (prev)
3124 SCHEME_CDR(prev) = scheme_null;
3125 else
3126 ra = scheme_null;
3127 break;
3128 }
3129 }
3130 prev = lra;
3131 lra = SCHEME_CDR(lra);
3132 }
3133 if (SCHEME_NULLP(ra))
3134 break;
3135 }
3136 }
3137
3138 if (SCHEME_NULLP(ol)) {
3139 return 0;
3140 }
3141
3142 req = SCHEME_CDR(req);
3143 }
3144
3145 return 1;
3146 }
3147
proc_is_method(Scheme_Object * proc)3148 static int proc_is_method(Scheme_Object *proc)
3149 {
3150 if (SCHEME_CHAPERONEP(proc))
3151 proc = SCHEME_CHAPERONE_VAL(proc);
3152
3153 if (SCHEME_STRUCTP(proc)
3154 && scheme_is_struct_instance(scheme_reduced_procedure_struct, proc))
3155 return SCHEME_TRUEP(((Scheme_Structure *)proc)->slots[3]);
3156
3157 if (SAME_TYPE(SCHEME_TYPE(proc), scheme_case_closure_type)) {
3158 Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)proc;
3159 if (cl->count)
3160 proc = cl->array[0];
3161 else
3162 return 0;
3163 }
3164
3165 if (SAME_TYPE(SCHEME_TYPE(proc), scheme_closure_type)) {
3166 return ((SCHEME_LAMBDA_FLAGS(SCHEME_CLOSURE_CODE(proc)) & LAMBDA_IS_METHOD)
3167 ? 1
3168 : 0);
3169 }
3170
3171 #ifdef MZ_USE_JIT
3172 if (SAME_TYPE(SCHEME_TYPE(proc), scheme_native_closure_type)) {
3173 Scheme_Object *pa;
3174 pa = scheme_get_native_arity(proc, -1);
3175 return SCHEME_BOXP(pa);
3176 }
3177 #endif
3178
3179 return 0;
3180 }
3181
do_procedure_reduce_arity(const char * who,int argc,Scheme_Object * argv[],int as_arity)3182 static Scheme_Object *do_procedure_reduce_arity(const char *who, int argc, Scheme_Object *argv[], int as_arity)
3183 {
3184 Scheme_Object *orig, *mask, *is_meth = NULL, *name = NULL;
3185
3186 if (!SCHEME_PROCP(argv[0]))
3187 scheme_wrong_contract("procedure-reduce-arity", "procedure?", 0, argc, argv);
3188
3189 if (as_arity) {
3190 if (!is_arity(argv[1], 1, 1)) {
3191 scheme_wrong_contract(who,
3192 "(or/c exact-nonnegative-integer? arity-at-least? (listof (or/c exact-nonnegative-integer? arity-at-least?)))",
3193 1, argc, argv);
3194 }
3195 mask = arity_to_mask(argv[1]);
3196 } else {
3197 mask = argv[1];
3198 if (!scheme_exact_p(mask)) {
3199 scheme_wrong_contract(who, "exact-integer?", 1, argc, argv);
3200 return NULL;
3201 }
3202 }
3203
3204 if (argc > 2) {
3205 name = argv[2];
3206 if (SCHEME_FALSEP(name))
3207 name = NULL;
3208 else if (!SCHEME_SYMBOLP(name)) {
3209 scheme_wrong_contract(who, "(or/c symbol? #f)", 2, argc, argv);
3210 return NULL;
3211 }
3212 } else
3213 name = NULL;
3214
3215 /* Check whether current arity covers the requested arity. */
3216
3217 orig = get_or_check_arity(argv[0], -4, NULL, 1);
3218
3219 if (!scheme_bin_eq(scheme_bin_bitwise_and(mask, orig), mask)) {
3220 scheme_contract_error(who,
3221 (as_arity
3222 ? "arity of procedure does not include requested arity"
3223 : "arity mask of procedure does not include requested arity mask"),
3224 "procedure", 1, argv[0],
3225 (as_arity ? "requested arity" : "requested arity mask"), 1, argv[1],
3226 NULL);
3227 return NULL;
3228 }
3229
3230 if (proc_is_method(argv[0]))
3231 is_meth = scheme_true;
3232
3233 /* Construct a procedure that has the given arity. */
3234 return make_reduced_proc(argv[0], mask, name, is_meth);
3235 }
3236
procedure_reduce_arity(int argc,Scheme_Object * argv[])3237 static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[])
3238 {
3239 return do_procedure_reduce_arity("procedure-reduce-arity", argc, argv, 1);
3240 }
3241
procedure_reduce_arity_mask(int argc,Scheme_Object * argv[])3242 static Scheme_Object *procedure_reduce_arity_mask(int argc, Scheme_Object *argv[])
3243 {
3244 return do_procedure_reduce_arity("procedure-reduce-arity-mask", argc, argv, 0);
3245 }
3246
procedure_rename(int argc,Scheme_Object * argv[])3247 static Scheme_Object *procedure_rename(int argc, Scheme_Object *argv[])
3248 {
3249 Scheme_Object *p, *mask;
3250
3251 if (!SCHEME_PROCP(argv[0]))
3252 scheme_wrong_contract("procedure-rename", "procedure?", 0, argc, argv);
3253 if (!SCHEME_SYMBOLP(argv[1]))
3254 scheme_wrong_contract("procedure-rename", "symbol?", 1, argc, argv);
3255
3256 p = scheme_rename_struct_proc(argv[0], argv[1]);
3257 if (p) return p;
3258
3259 mask = get_or_check_arity(argv[0], -4, NULL, 1);
3260
3261 return make_reduced_proc(argv[0], mask, argv[1], NULL);
3262 }
3263
procedure_to_method(int argc,Scheme_Object * argv[])3264 static Scheme_Object *procedure_to_method(int argc, Scheme_Object *argv[])
3265 {
3266 Scheme_Object *mask;
3267
3268 if (!SCHEME_PROCP(argv[0]))
3269 scheme_wrong_contract("procedure->method", "procedure?", 0, argc, argv);
3270
3271 mask = get_or_check_arity(argv[0], -4, NULL, 1);
3272
3273 return make_reduced_proc(argv[0], mask, NULL, scheme_true);
3274 }
3275
procedure_equal_closure_p(int argc,Scheme_Object * argv[])3276 static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[])
3277 {
3278 Scheme_Object *v1 = argv[0], *v2 = argv[1];
3279
3280 if (!SCHEME_PROCP(v1))
3281 scheme_wrong_contract("procedure-closure-contents-eq?", "procedure?", 0, argc, argv);
3282 if (!SCHEME_PROCP(v2))
3283 scheme_wrong_contract("procedure-closure-contents-eq?", "procedure?", 1, argc, argv);
3284
3285 if (SAME_OBJ(v1, v2))
3286 return scheme_true;
3287
3288 if (!SAME_TYPE(SCHEME_TYPE(v1), SCHEME_TYPE(v2)))
3289 return scheme_false;
3290
3291 switch (SCHEME_TYPE(v1)) {
3292 case scheme_prim_type:
3293 {
3294 Scheme_Primitive_Proc *p1 = (Scheme_Primitive_Proc *)v1;
3295 Scheme_Primitive_Proc *p2 = (Scheme_Primitive_Proc *)v2;
3296
3297 if (p1->prim_val == p2->prim_val) {
3298 if (p1->pp.flags & SCHEME_PRIM_IS_CLOSURE) {
3299 if (!(p2->pp.flags & SCHEME_PRIM_IS_CLOSURE))
3300 return scheme_false;
3301
3302 /* They both are closures, but we don't know how
3303 many fields in each, except in 3m mode. So
3304 give up. */
3305 return scheme_false;
3306 } else if (!(p2->pp.flags & SCHEME_PRIM_IS_CLOSURE))
3307 return scheme_true;
3308 }
3309 }
3310 break;
3311 case scheme_closure_type:
3312 {
3313 Scheme_Closure *c1 = (Scheme_Closure *)v1;
3314 Scheme_Closure *c2 = (Scheme_Closure *)v2;
3315
3316 if (SAME_OBJ(c1->code, c2->code)) {
3317 int i;
3318 for (i = c1->code->closure_size; i--; ) {
3319 if (!SAME_OBJ(c1->vals[i], c2->vals[i]))
3320 return scheme_false;
3321 }
3322 return scheme_true;
3323 }
3324 }
3325 break;
3326 case scheme_native_closure_type:
3327 {
3328 Scheme_Native_Closure *c1 = (Scheme_Native_Closure *)v1;
3329 Scheme_Native_Closure *c2 = (Scheme_Native_Closure *)v2;
3330
3331 if (SAME_OBJ(c1->code, c2->code)
3332 || (c1->code->eq_key && SAME_OBJ(c1->code->eq_key, c2->code->eq_key))) {
3333 int i;
3334 i = c1->code->closure_size;
3335 if (i < 0) {
3336 /* A case closure */
3337 Scheme_Native_Closure *sc1, *sc2;
3338 int j;
3339 i = -(i + 1);
3340 while (i--) {
3341 sc1 = (Scheme_Native_Closure *)c1->vals[i];
3342 sc2 = (Scheme_Native_Closure *)c2->vals[i];
3343 j = sc1->code->closure_size;
3344 while (j--) {
3345 if (!SAME_OBJ(sc1->vals[j], sc2->vals[j]))
3346 return scheme_false;
3347 }
3348 }
3349 } else {
3350 /* Normal closure: */
3351 while (i--) {
3352 if (!SAME_OBJ(c1->vals[i], c2->vals[i]))
3353 return scheme_false;
3354 }
3355 }
3356 return scheme_true;
3357 }
3358 }
3359 break;
3360 case scheme_case_closure_type:
3361 {
3362 Scheme_Case_Lambda *c1 = (Scheme_Case_Lambda *)v1;
3363 Scheme_Case_Lambda *c2 = (Scheme_Case_Lambda *)v2;
3364 if (c1->count == c2->count) {
3365 Scheme_Closure *sc1, *sc2;
3366 int i, j;
3367 for (i = c1->count; i--; ) {
3368 sc1 = (Scheme_Closure *)c1->array[i];
3369 sc2 = (Scheme_Closure *)c2->array[i];
3370 if (!SAME_OBJ(sc1->code, sc2->code))
3371 return scheme_false;
3372 for (j = sc1->code->closure_size; j--; ) {
3373 if (!SAME_OBJ(sc1->vals[j], sc2->vals[j]))
3374 return scheme_false;
3375 }
3376 }
3377 return scheme_true;
3378 }
3379 }
3380 break;
3381 }
3382
3383 return scheme_false;
3384 }
3385
procedure_specialize(int argc,Scheme_Object * argv[])3386 static Scheme_Object *procedure_specialize(int argc, Scheme_Object *argv[])
3387 {
3388 if (!SCHEME_PROCP(argv[0]))
3389 scheme_wrong_contract("procedure-specialize", "procedure?", 0, argc, argv);
3390
3391 #ifdef MZ_USE_JIT
3392 if (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_native_closure_type)) {
3393 Scheme_Native_Closure *nc = (Scheme_Native_Closure *)argv[0];
3394 if ((nc->code->start_code == scheme_on_demand_jit_code)
3395 && !(SCHEME_NATIVE_LAMBDA_FLAGS(nc->code) & NATIVE_SPECIALIZED)) {
3396 Scheme_Native_Lambda *data;
3397 if (!nc->code->eq_key) {
3398 void *p;
3399 p = scheme_malloc_atomic(sizeof(int));
3400 nc->code->eq_key = p;
3401 }
3402 data = MALLOC_ONE_TAGGED(Scheme_Native_Lambda);
3403 memcpy(data, nc->code, sizeof(Scheme_Native_Lambda));
3404 SCHEME_NATIVE_LAMBDA_FLAGS(data) |= NATIVE_SPECIALIZED;
3405 nc->code = data;
3406 }
3407 }
3408 #endif
3409
3410 return argv[0];
3411 }
3412
do_chaperone_procedure(const char * name,const char * whating,int is_impersonator,int pass_self,int argc,Scheme_Object * argv[],int is_unsafe)3413 static Scheme_Object *do_chaperone_procedure(const char *name, const char *whating,
3414 int is_impersonator, int pass_self,
3415 int argc, Scheme_Object *argv[], int is_unsafe)
3416 {
3417 Scheme_Chaperone *px, *px2;
3418 Scheme_Object *val = argv[0], *orig, *r, *app_mark;
3419 Scheme_Object *props;
3420
3421 if (SCHEME_CHAPERONEP(val))
3422 val = SCHEME_CHAPERONE_VAL(val);
3423
3424 if (!SCHEME_PROCP(val))
3425 scheme_wrong_contract(name, "procedure?", 0, argc, argv);
3426 if (is_unsafe) {
3427 if (!SCHEME_PROCP(argv[1]))
3428 scheme_wrong_contract(name, "procedure?", 1, argc, argv);
3429 } else {
3430 if (!SCHEME_FALSEP(argv[1]) && !SCHEME_PROCP(argv[1]))
3431 scheme_wrong_contract(name, "(or/c procedure? #f)", 1, argc, argv);
3432 }
3433
3434 orig = get_or_check_arity(val, -1, NULL, 1);
3435 if (!SCHEME_FALSEP(argv[1])) {
3436 Scheme_Object *naya;
3437 naya = get_or_check_arity(argv[1], -1, NULL, 1);
3438
3439 if (!is_subarity(orig, naya, pass_self ? 1 : 0))
3440 scheme_raise_exn(MZEXN_FAIL_CONTRACT,
3441 "%s: arity of wrapper procedure does not cover arity of original procedure%s\n"
3442 " wrapper: %V\n"
3443 " original: %V",
3444 name,
3445 (pass_self ? " (adding an extra argument)": ""),
3446 argv[1],
3447 argv[0]);
3448 }
3449
3450 props = scheme_parse_chaperone_props(name, 2, argc, argv);
3451 if (props) {
3452 app_mark = scheme_chaperone_props_get(props, scheme_app_mark_impersonator_property);
3453 if (app_mark) {
3454 /* don't need to keep the property */
3455 props = scheme_chaperone_props_remove(props, scheme_app_mark_impersonator_property);
3456 } else
3457 app_mark = scheme_false;
3458 } else
3459 app_mark = scheme_false;
3460
3461 if (SCHEME_FALSEP(argv[1]) && SCHEME_FALSEP(app_mark) && !props)
3462 return argv[0];
3463
3464 /* app_mark should be (cons mark val) */
3465 if (SCHEME_FALSEP(app_mark) && !SCHEME_PAIRP(app_mark))
3466 app_mark = scheme_false;
3467
3468 px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
3469 px->iso.so.type = scheme_proc_chaperone_type;
3470 px->val = val;
3471 px->prev = argv[0];
3472 px->props = props;
3473
3474 /* Put the procedure along with known-good arity (to speed checking;
3475 initialized to -1) in a vector.
3476
3477 Vector of odd size for redirects means a procedure chaperone,
3478 vector with non-zero even slots means a structure chaperone,
3479 vector with zero slots means a property-only vector chaperone.
3480 A size of 5 (instead of 3) indicates that the wrapper
3481 procedure accepts a "self" argument. An immutable vector
3482 means that it wraps a chaperone that wants the "self"
3483 argument.
3484
3485 If the known-good arity is #f, this means the chaperone
3486 wrapper defers directly to SCHEME_VEC_ELES(r)[0] and no
3487 arity check is needed.
3488 */
3489 r = scheme_make_vector((pass_self ? 5 : 3), scheme_make_integer(-1));
3490
3491 if (SCHEME_FALSEP(argv[1]))
3492 SCHEME_VEC_ELS(r)[0] = argv[0];
3493 else
3494 SCHEME_VEC_ELS(r)[0] = argv[1];
3495 if (SCHEME_FALSEP(argv[1]))
3496 SCHEME_VEC_ELS(r)[1] = scheme_false;
3497 SCHEME_VEC_ELS(r)[2] = app_mark;
3498
3499 px->redirects = r;
3500
3501 if (is_impersonator)
3502 SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;
3503 if (is_unsafe || SCHEME_FALSEP(argv[1]))
3504 SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_PROC_CHAPERONE_CALL_DIRECT;
3505
3506 if (!is_unsafe) {
3507 /* If there's a `pass_self` chaperone in px->prev, then we'll need
3508 to pass the self proc along. */
3509 for (val = px->prev; SCHEME_P_CHAPERONEP(val); val = ((Scheme_Chaperone *)val)->prev) {
3510 px2 = (Scheme_Chaperone *)val;
3511 if (SCHEME_REDIRECTS_PROCEDUREP(px2->redirects)) {
3512 if ((SCHEME_VEC_SIZE(px2->redirects) > 3)
3513 || SCHEME_IMMUTABLEP(px2->redirects))
3514 SCHEME_SET_IMMUTABLE(px->redirects);
3515 break;
3516 }
3517 }
3518 }
3519
3520 return (Scheme_Object *)px;
3521 }
3522
chaperone_procedure(int argc,Scheme_Object * argv[])3523 static Scheme_Object *chaperone_procedure(int argc, Scheme_Object *argv[])
3524 {
3525 return do_chaperone_procedure("chaperone-procedure", "chaperoning", 0, 0, argc, argv, 0);
3526 }
3527
unsafe_chaperone_procedure(int argc,Scheme_Object * argv[])3528 static Scheme_Object *unsafe_chaperone_procedure(int argc, Scheme_Object *argv[])
3529 {
3530 return do_chaperone_procedure("unsafe-chaperone-procedure", "chaperoning", 0, 0, argc, argv, 1);
3531 }
3532
impersonate_procedure(int argc,Scheme_Object * argv[])3533 static Scheme_Object *impersonate_procedure(int argc, Scheme_Object *argv[])
3534 {
3535 return do_chaperone_procedure("impersonate-procedure", "impersonating", 1, 0, argc, argv, 0);
3536 }
3537
unsafe_impersonate_procedure(int argc,Scheme_Object * argv[])3538 static Scheme_Object *unsafe_impersonate_procedure(int argc, Scheme_Object *argv[])
3539 {
3540 return do_chaperone_procedure("unsafe-impersonate-procedure", "impersonating", 1, 0, argc, argv, 1);
3541 }
3542
chaperone_procedure_star(int argc,Scheme_Object * argv[])3543 static Scheme_Object *chaperone_procedure_star(int argc, Scheme_Object *argv[])
3544 {
3545 return do_chaperone_procedure("chaperone-procedure*", "chaperoning", 0, 1, argc, argv, 0);
3546 }
3547
impersonate_procedure_star(int argc,Scheme_Object * argv[])3548 static Scheme_Object *impersonate_procedure_star(int argc, Scheme_Object *argv[])
3549 {
3550 return do_chaperone_procedure("impersonate-procedure*", "impersonating", 1, 1, argc, argv, 0);
3551 }
3552
apply_chaperone_k(void)3553 static Scheme_Object *apply_chaperone_k(void)
3554 {
3555 Scheme_Thread *p = scheme_current_thread;
3556 Scheme_Object *o = (Scheme_Object *)p->ku.k.p1;
3557 Scheme_Object **argv = (Scheme_Object **)p->ku.k.p2;
3558 Scheme_Object *auto_val = (Scheme_Object *)p->ku.k.p3;
3559
3560 p->ku.k.p1 = NULL;
3561 p->ku.k.p2 = NULL;
3562 p->ku.k.p3 = NULL;
3563
3564 return scheme_apply_chaperone(o, p->ku.k.i1, argv, auto_val, p->ku.k.i2);
3565 }
3566
do_apply_chaperone(Scheme_Object * o,int argc,Scheme_Object ** argv,Scheme_Object * auto_val,int checks)3567 static Scheme_Object *do_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv, Scheme_Object *auto_val, int checks)
3568 {
3569 #ifdef DO_STACK_CHECK
3570 {
3571 # include "mzstkchk.h"
3572 {
3573 Scheme_Thread *p = scheme_current_thread;
3574 Scheme_Object **argv2;
3575 argv2 = MALLOC_N(Scheme_Object*, argc);
3576 memcpy(argv2, argv, sizeof(Scheme_Object *) * argc);
3577 p->ku.k.p1 = (void *)o;
3578 p->ku.k.p2 = (void *)argv2;
3579 p->ku.k.p3 = (void *)auto_val;
3580 p->ku.k.i1 = argc;
3581 p->ku.k.i2 = checks;
3582 return scheme_handle_stack_overflow(apply_chaperone_k);
3583 }
3584 }
3585 #endif
3586
3587 return scheme_apply_chaperone(o, argc, argv, auto_val, checks);
3588 }
3589
3590
_apply_native(Scheme_Object * obj,int num_rands,Scheme_Object ** rands)3591 static Scheme_Object *_apply_native(Scheme_Object *obj, int num_rands, Scheme_Object **rands)
3592 {
3593 Scheme_Native_Lambda *data;
3594 GC_MAYBE_IGNORE_INTERIOR MZ_MARK_STACK_TYPE old_cont_mark_stack;
3595 GC_MAYBE_IGNORE_INTERIOR Scheme_Object **rs;
3596
3597 data = ((Scheme_Native_Closure *)obj)->code;
3598
3599 if ((uintptr_t)data->max_let_depth > ((uintptr_t)scheme_current_runstack - (uintptr_t)scheme_current_runstack_start)) {
3600 return _scheme_apply_multi(obj, num_rands, rands);
3601 }
3602
3603 MZ_CONT_MARK_POS += 2;
3604 old_cont_mark_stack = MZ_CONT_MARK_STACK;
3605 rs = MZ_RUNSTACK;
3606
3607 obj = data->start_code(obj, num_rands, rands EXTRA_NATIVE_ARGUMENT);
3608
3609 if (obj == SCHEME_TAIL_CALL_WAITING)
3610 obj = scheme_force_value_same_mark(obj);
3611
3612 MZ_CONT_MARK_STACK = old_cont_mark_stack;
3613 MZ_CONT_MARK_POS -= 2;
3614 MZ_RUNSTACK = rs;
3615
3616 return obj;
3617 }
3618
_scheme_apply_native(Scheme_Object * obj,int num_rands,Scheme_Object ** rands)3619 Scheme_Object *_scheme_apply_native(Scheme_Object *obj, int num_rands, Scheme_Object **rands)
3620 {
3621 return _apply_native(obj, num_rands, rands);
3622 }
3623
extract_impersonator_results(int c,int argc,Scheme_Object ** argv2,const char * what,Scheme_Object * o,Scheme_Chaperone * px,Scheme_Cont_Frame_Data * cframe,int * _need_pop)3624 Scheme_Object *extract_impersonator_results(int c, int argc, Scheme_Object **argv2,
3625 const char *what, Scheme_Object *o,
3626 Scheme_Chaperone *px,
3627 Scheme_Cont_Frame_Data *cframe, int *_need_pop)
3628 {
3629 int extra = c - argc;
3630 int i, fail_reason = 0;
3631 Scheme_Object *post;
3632 char nth[32];
3633 Scheme_Config *config = NULL;
3634
3635 if (!extra)
3636 return NULL;
3637
3638 post = NULL;
3639 for (i = 0; i < extra; ) {
3640 if (!i && SCHEME_PROCP(argv2[0])) {
3641 post = argv2[i];
3642 i++;
3643 } else if (SAME_OBJ(argv2[i], mark_symbol)) {
3644 if (i + 3 > extra) {
3645 fail_reason = 2;
3646 break;
3647 }
3648 if (post && !*_need_pop) {
3649 scheme_push_continuation_frame(cframe);
3650 *_need_pop = 1;
3651 }
3652 scheme_set_cont_mark(argv2[i+1], argv2[i+2]);
3653 i += 3;
3654 } else {
3655 fail_reason = 1;
3656 break;
3657 }
3658 }
3659
3660 if (!fail_reason) {
3661 if (config) {
3662 if (post && !*_need_pop) {
3663 scheme_push_continuation_frame(cframe);
3664 *_need_pop = 1;
3665 }
3666 scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config);
3667 }
3668 return post;
3669 }
3670
3671 /* Failure at argument i */
3672
3673 switch (i % 10) {
3674 case 1:
3675 sprintf(nth, "%dst", i);
3676 break;
3677 case 2:
3678 sprintf(nth, "%dnd", i);
3679 break;
3680 case 3:
3681 sprintf(nth, "%drd", i);
3682 break;
3683 default:
3684 sprintf(nth, "%dth", i);
3685 }
3686
3687 if (fail_reason == 1) {
3688 scheme_raise_exn(MZEXN_FAIL_CONTRACT,
3689 "procedure %s: wrapper's %s result is not valid;\n"
3690 " %s extra result (before original argument count) should be\n"
3691 " 'mark%s\n"
3692 " original: %V\n"
3693 " wrapper: %V\n"
3694 " received: %V",
3695 what,
3696 nth,
3697 nth,
3698 (i ? "" : " or a wrapper for the original procedure's result"),
3699 o,
3700 SCHEME_VEC_ELS(px->redirects)[0],
3701 argv2[i]);
3702 } else if (fail_reason == 2) {
3703 scheme_raise_exn(MZEXN_FAIL_CONTRACT,
3704 "procedure %s: wrapper's %s result needs addition extra results;\n"
3705 " %s extra result (before original argument count) needs an\n"
3706 " additional %s after %V\n"
3707 " original: %V\n"
3708 " wrapper: %V",
3709 what,
3710 nth,
3711 nth,
3712 ((i + 1 < extra) ? "result" : "two results"),
3713 argv2[i],
3714 o,
3715 SCHEME_VEC_ELS(px->redirects)[0]);
3716 }
3717
3718 return NULL;
3719 }
3720
3721 /* must be at least 3: */
3722 #define MAX_QUICK_CHAP_ARGV 5
3723
3724 #define CHAPERONE_KIND_STR(px) (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR) ? "chaperone" : "impersonator")
3725
scheme_apply_chaperone(Scheme_Object * o,int argc,Scheme_Object ** argv,Scheme_Object * auto_val,int checks)3726 Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv, Scheme_Object *auto_val, int checks)
3727 /* auto_val => no need to actually call the function (but handle further chaperoning);
3728 checks & 0x2 => no tail; checks == 0x3 => no tail or multiple */
3729 {
3730 Scheme_Chaperone *px;
3731 Scheme_Object *v, *a[1], *a2[MAX_QUICK_CHAP_ARGV], **argv2, *post, *result_v, *orig_obj, *app_mark, *self_proc, *simple_call;
3732 int c, i, need_restore = 0;
3733 int need_pop_mark;
3734 Scheme_Cont_Frame_Data cframe;
3735
3736 if (SCHEME_RPAIRP(o)) {
3737 /* An applicable struct, where a layer of struct chaperones
3738 has been removed from the object to apply, but we will
3739 eventually need to extract the procedure from the original
3740 object. */
3741 orig_obj = SCHEME_CDR(o);
3742 o = SCHEME_CAR(o);
3743 } else {
3744 orig_obj = NULL;
3745 }
3746 px = (Scheme_Chaperone *)o;
3747
3748 {
3749 Scheme_Thread *p = scheme_current_thread;
3750 self_proc = p->self_for_proc_chaperone;
3751 if (self_proc)
3752 p->self_for_proc_chaperone = NULL;
3753 else
3754 self_proc = o;
3755 }
3756
3757 /* Ensure that the original procedure accepts `argc' arguments: */
3758 if (!SCHEME_FALSEP(SCHEME_VEC_ELS(px->redirects)[1]) /* check not needed for props-only mode */
3759 && (argc != SCHEME_INT_VAL(SCHEME_VEC_ELS(px->redirects)[1]))) {
3760 a[0] = px->prev;
3761 if (!scheme_check_proc_arity(NULL, argc, 0, 0, a)) {
3762 /* Apply the original procedure, in case the chaperone would accept
3763 `argc' arguments (in addition to the original procedure's arity)
3764 in case the methodness of the original procedure is different
3765 from the chaperone, or in case the procedures have different names. */
3766 (void)_scheme_apply_multi(px->prev, argc, argv);
3767 scheme_signal_error("internal error: unexpected success applying chaperoned/proxied procedure");
3768 return NULL;
3769 }
3770 /* record that argc is ok, on the grounds that the function is likely
3771 to be applied to argc arguments again */
3772 SCHEME_VEC_ELS(px->redirects)[1] = scheme_make_integer(argc);
3773 }
3774
3775 if (SCHEME_CHAPERONE_FLAGS(px) & SCHEME_PROC_CHAPERONE_CALL_DIRECT) {
3776 if (auto_val)
3777 return argv[0];
3778 simple_call = SCHEME_VEC_ELS(px->redirects)[0];
3779 /* no redirection procedure */
3780 if (SCHEME_IMMUTABLEP(px->redirects)) {
3781 /* communicate `self_proc` to the next layer: */
3782 scheme_current_thread->self_for_proc_chaperone = self_proc;
3783 }
3784 if (checks) {
3785 /* cannot return a tail call */
3786 MZ_CONT_MARK_POS -= 2;
3787 if (checks & 0x1) {
3788 v = _scheme_apply(simple_call, argc, argv);
3789 } else if (SAME_TYPE(SCHEME_TYPE(simple_call), scheme_native_closure_type)) {
3790 v = _apply_native(simple_call, argc, argv);
3791 } else {
3792 v = _scheme_apply_multi(simple_call, argc, argv);
3793 }
3794 MZ_CONT_MARK_POS += 2;
3795 return v;
3796 } else
3797 return _scheme_tail_apply(simple_call, argc, argv);
3798 }
3799
3800 if (argv == MZ_RUNSTACK) {
3801 /* Pushing onto the runstack ensures that `(vector-ref px->redirects 0)' won't
3802 modify argv. */
3803 if (MZ_RUNSTACK > MZ_RUNSTACK_START) {
3804 --MZ_RUNSTACK;
3805 *MZ_RUNSTACK = NULL;
3806 need_restore = 1;
3807 } else {
3808 /* Can't push! Just allocate a copy. */
3809 argv2 = MALLOC_N(Scheme_Object *, argc);
3810 memcpy(argv2, argv, sizeof(Scheme_Object*) * argc);
3811 argv = argv2;
3812 }
3813 }
3814
3815 app_mark = SCHEME_VEC_ELS(px->redirects)[2];
3816 if (SCHEME_FALSEP(app_mark))
3817 app_mark = NULL;
3818
3819 if (app_mark) {
3820 v = scheme_chaperone_get_immediate_cc_mark(SCHEME_CAR(app_mark), NULL);
3821 if (v) {
3822 scheme_push_continuation_frame(&cframe);
3823 scheme_set_cont_mark(SCHEME_CAR(app_mark), v);
3824 MZ_CONT_MARK_POS -= 2;
3825 need_pop_mark = 1;
3826 } else
3827 need_pop_mark = 0;
3828 } else
3829 need_pop_mark = 0;
3830
3831 if (SCHEME_VEC_SIZE(px->redirects) > 3) {
3832 /* wrapper wants the "self" argument */
3833 c = argc+1;
3834 if (c <= MAX_QUICK_CHAP_ARGV)
3835 argv2 = a2;
3836 else
3837 argv2 = MALLOC_N(Scheme_Object *, MAX_QUICK_CHAP_ARGV);
3838 for (i = 0; i < argc; i++) {
3839 argv2[i+1] = argv[i];
3840 }
3841 argv2[0] = self_proc;
3842 } else {
3843 /* wrapper doesn't need the extra "self" argument */
3844 c = argc;
3845 argv2 = argv;
3846 }
3847
3848 v = SCHEME_VEC_ELS(px->redirects)[0];
3849 if (SAME_TYPE(SCHEME_TYPE(v), scheme_native_closure_type))
3850 v = _apply_native(v, c, argv2);
3851 else
3852 v = _scheme_apply_multi(v, c, argv2);
3853
3854 if (v == SCHEME_MULTIPLE_VALUES) {
3855 GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread;
3856 c = p->ku.multiple.count;
3857 argv2 = p->ku.multiple.array;
3858 p->ku.multiple.array = NULL;
3859 if (SAME_OBJ(argv2, p->values_buffer)) {
3860 if (c <= MAX_QUICK_CHAP_ARGV) {
3861 for (i = 0; i < c; i++) {
3862 a2[i] = argv2[i];
3863 }
3864 argv2 = a2;
3865 } else {
3866 p->values_buffer = NULL;
3867 }
3868 }
3869 } else {
3870 c = 1;
3871 a2[0] = v;
3872 argv2 = a2;
3873 }
3874
3875 if (need_pop_mark) {
3876 MZ_CONT_MARK_POS += 2;
3877 scheme_pop_continuation_frame(&cframe);
3878 }
3879
3880 if (c >= argc) {
3881 int need_pop = 0;
3882 post = extract_impersonator_results(c, argc, argv2,
3883 CHAPERONE_KIND_STR(px), o, px,
3884 &cframe, &need_pop);
3885 need_pop_mark = need_pop;
3886
3887 if (c > argc)
3888 memmove(argv2, argv2 + (c - argc), sizeof(Scheme_Object*)*argc);
3889 if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) {
3890 for (i = 0; i < argc; i++) {
3891 if (!SAME_OBJ(argv2[i], argv[i])
3892 && !scheme_chaperone_of(argv2[i], argv[i])) {
3893 if (argc == 1)
3894 scheme_wrong_chaperoned("procedure chaperone", "argument", argv[i], argv2[i]);
3895 else {
3896 char nbuf[32];
3897 sprintf(nbuf, "%d%s argument", i, scheme_number_suffix(i));
3898 scheme_wrong_chaperoned("procedure chaperone", nbuf, argv[i], argv2[i]);
3899 }
3900 }
3901 }
3902 }
3903 } else {
3904 scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY,
3905 "procedure %s: arity mismatch;\n"
3906 " expected number of results not received from wrapper on the original\n"
3907 " procedure's arguments\n"
3908 " original: %V\n"
3909 " wrapper: %V\n"
3910 " expected: %d or more\n"
3911 " received: %d",
3912 CHAPERONE_KIND_STR(px),
3913 o,
3914 SCHEME_VEC_ELS(px->redirects)[0],
3915 argc,
3916 c);
3917 return NULL;
3918 }
3919
3920 if (need_restore) {
3921 /* As a step toward space safety, even clear out the arguments
3922 form the runstack: */
3923 MZ_RUNSTACK++;
3924 for (i = 0; i < argc; i++) {
3925 argv[i] = NULL;
3926 }
3927 } else
3928 argv = NULL;
3929
3930 if (!post) {
3931 /* No filter for the result, so tail call: */
3932 if (app_mark)
3933 scheme_set_cont_mark(SCHEME_CAR(app_mark), SCHEME_CDR(app_mark));
3934 if (SCHEME_IMMUTABLEP(px->redirects)) {
3935 /* commuincate `self_proc` to the next layer: */
3936 scheme_current_thread->self_for_proc_chaperone = self_proc;
3937 }
3938 if (auto_val) {
3939 if (SCHEME_CHAPERONEP(px->prev))
3940 return do_apply_chaperone(px->prev, argc, argv2, auto_val, 0);
3941 else
3942 return argv2[0];
3943 } else {
3944 if (orig_obj)
3945 /* A raw pair tells apply to extract a procedure from orig_obj */
3946 orig_obj = scheme_make_raw_pair(px->prev, orig_obj);
3947 else
3948 orig_obj = px->prev;
3949 if (checks) {
3950 /* cannot return a tail call */
3951 MZ_CONT_MARK_POS -= 2;
3952 if (checks & 0x1) {
3953 v = _scheme_apply(orig_obj, argc, argv2);
3954 } else if (SAME_TYPE(SCHEME_TYPE(orig_obj), scheme_native_closure_type)) {
3955 v = _apply_native(orig_obj, argc, argv2);
3956 } else {
3957 v = _scheme_apply_multi(orig_obj, argc, argv2);
3958 }
3959 MZ_CONT_MARK_POS += 2;
3960 return v;
3961 } else
3962 return scheme_tail_apply(orig_obj, argc, argv2);
3963 }
3964 } else {
3965 if (app_mark) {
3966 if (!need_pop_mark)
3967 scheme_push_continuation_frame(&cframe);
3968 scheme_set_cont_mark(SCHEME_CAR(app_mark), SCHEME_CDR(app_mark));
3969 need_pop_mark = 1;
3970 }else
3971 need_pop_mark = 0;
3972
3973 if (need_pop_mark)
3974 MZ_CONT_MARK_POS -= 2;
3975
3976 if (SCHEME_IMMUTABLEP(px->redirects)) {
3977 /* commuincate `self_proc` to the next layer: */
3978 scheme_current_thread->self_for_proc_chaperone = self_proc;
3979 }
3980
3981 if (auto_val) {
3982 if (SCHEME_CHAPERONEP(px->prev))
3983 result_v = do_apply_chaperone(px->prev, argc, argv2, auto_val, 0);
3984 else
3985 result_v = argv2[0];
3986 v = auto_val;
3987 } else {
3988 if (orig_obj)
3989 /* A raw pair tells apply to extract a procedure from orig_obj */
3990 orig_obj = scheme_make_raw_pair(px->prev, orig_obj);
3991 else
3992 orig_obj = px->prev;
3993 if (SAME_TYPE(SCHEME_TYPE(orig_obj), scheme_native_closure_type))
3994 v = _apply_native(orig_obj, argc, argv2);
3995 else
3996 v = _scheme_apply_multi(orig_obj, argc, argv2);
3997 result_v = NULL;
3998 }
3999
4000 if (v == SCHEME_MULTIPLE_VALUES) {
4001 GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread;
4002 if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
4003 p->values_buffer = NULL;
4004 c = p->ku.multiple.count;
4005 argv = p->ku.multiple.array;
4006 p->ku.multiple.array = NULL;
4007 } else {
4008 c = 1;
4009 a[0] = v;
4010 argv = a;
4011 }
4012
4013 if (need_pop_mark) {
4014 MZ_CONT_MARK_POS += 2;
4015 scheme_pop_continuation_frame(&cframe);
4016 }
4017
4018 if (!scheme_check_proc_arity(NULL, c, 0, -1, &post))
4019 scheme_raise_exn(MZEXN_FAIL_CONTRACT,
4020 "procedure-result %s: arity mismatch;\n"
4021 " wrapper does not accept the number of values produced by\n"
4022 " the original procedure\n"
4023 " original: %V\n"
4024 " wrapper: %V\n"
4025 " number of values: %d",
4026 CHAPERONE_KIND_STR(px),
4027 o,
4028 post,
4029 c);
4030
4031 if (SAME_TYPE(SCHEME_TYPE(post), scheme_native_closure_type))
4032 v = _apply_native(post, c, argv);
4033 else
4034 v = _scheme_apply_multi(post, c, argv);
4035 if (v == SCHEME_MULTIPLE_VALUES) {
4036 GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread;
4037 if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
4038 p->values_buffer = NULL;
4039 argc = p->ku.multiple.count;
4040 argv2 = p->ku.multiple.array;
4041 p->ku.multiple.array = NULL;
4042 } else {
4043 argc = 1;
4044 a2[0] = v;
4045 argv2 = a2;
4046 }
4047
4048 if (c == argc) {
4049 if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) {
4050 for (i = 0; i < argc; i++) {
4051 if (!SAME_OBJ(argv2[i], argv[i])
4052 && !scheme_chaperone_of(argv2[i], argv[i])) {
4053 if (argc == 1)
4054 scheme_wrong_chaperoned("procedure-result chaperone", "result", argv[i], argv2[i]);
4055 else {
4056 char nbuf[32];
4057 sprintf(nbuf, "%d%s result", i, scheme_number_suffix(i));
4058 scheme_wrong_chaperoned("procedure-result chaperone", nbuf, argv[i], argv2[i]);
4059 }
4060 }
4061 }
4062 }
4063 } else {
4064 scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY,
4065 "procedure-result %s: result arity mismatch;\n"
4066 " expected number of values not received from wrapper on the original\n"
4067 " procedure's result\n"
4068 " original: %V\n"
4069 " wrapper: %V\n"
4070 " expected: %d\n"
4071 " received: %d",
4072 CHAPERONE_KIND_STR(px),
4073 o,
4074 post,
4075 c, argc);
4076 return NULL;
4077 }
4078
4079 if (result_v)
4080 return result_v;
4081 else if (c == 1)
4082 return argv2[0];
4083 else {
4084 if (checks & 0x1)
4085 scheme_wrong_return_arity(NULL, 1, c, argv2, NULL);
4086 return scheme_values(c, argv2);
4087 }
4088 }
4089 }
4090
4091 static Scheme_Object *
apply(int argc,Scheme_Object * argv[])4092 apply(int argc, Scheme_Object *argv[])
4093 {
4094 Scheme_Object *rands;
4095 Scheme_Object **rand_vec;
4096 int i, num_rands;
4097 Scheme_Thread *p = scheme_current_thread;
4098
4099 if (!SCHEME_PROCP(argv[0])) {
4100 scheme_wrong_contract("apply", "procedure?", 0, argc, argv);
4101 return NULL;
4102 }
4103
4104 rands = argv[argc-1];
4105
4106 num_rands = scheme_proper_list_length(rands);
4107 if (num_rands < 0) {
4108 scheme_wrong_contract("apply", "list?", argc - 1, argc, argv);
4109 return NULL;
4110 }
4111 num_rands += (argc - 2);
4112
4113 if (num_rands > p->tail_buffer_size) {
4114 rand_vec = MALLOC_N(Scheme_Object *, num_rands);
4115 /* num_rands might be very big, so don't install it as the tail buffer */
4116 } else
4117 rand_vec = p->tail_buffer;
4118
4119 for (i = argc - 2; i--; ) {
4120 rand_vec[i] = argv[i + 1];
4121 }
4122
4123 for (i = argc - 2; SCHEME_PAIRP(rands); i++, rands = SCHEME_CDR(rands)) {
4124 rand_vec[i] = SCHEME_CAR(rands);
4125 }
4126
4127 p->ku.apply.tail_rator = argv[0];
4128 p->ku.apply.tail_rands = rand_vec;
4129 p->ku.apply.tail_num_rands = num_rands;
4130
4131 return SCHEME_TAIL_CALL_WAITING;
4132 }
4133
4134 #define DO_MAP map
4135 #define MAP_NAME "map"
4136 #define MAP_MODE
4137 #include "schmap.inc"
4138 #undef MAP_MODE
4139 #undef MAP_NAME
4140 #undef DO_MAP
4141
4142 #define DO_MAP for_each
4143 #define MAP_NAME "for-each"
4144 #define FOR_EACH_MODE
4145 #include "schmap.inc"
4146 #undef FOR_EACH_MODE
4147 #undef MAP_NAME
4148 #undef DO_MAP
4149
4150 #define DO_MAP andmap
4151 #define MAP_NAME "andmap"
4152 #define AND_MODE
4153 #include "schmap.inc"
4154 #undef AND_MODE
4155 #undef MAP_NAME
4156 #undef DO_MAP
4157
4158 #define DO_MAP ormap
4159 #define MAP_NAME "ormap"
4160 #define OR_MODE
4161 #include "schmap.inc"
4162 #undef OR_MODE
4163 #undef MAP_NAME
4164 #undef DO_MAP
4165
call_with_values(int argc,Scheme_Object * argv[])4166 static Scheme_Object *call_with_values(int argc, Scheme_Object *argv[])
4167 {
4168 Scheme_Thread *p;
4169 Scheme_Object *v;
4170
4171 scheme_check_proc_arity("call-with-values", 0, 0, argc, argv);
4172 if (!SCHEME_PROCP(argv[1]))
4173 scheme_wrong_contract("call-with-values", "procedure?", 1, argc, argv);
4174
4175 v = _scheme_apply_multi(argv[0], 0, NULL);
4176 p = scheme_current_thread;
4177 if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES)) {
4178 int n;
4179 Scheme_Object **a;
4180 if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
4181 p->values_buffer = NULL;
4182 n = p->ku.multiple.count;
4183 a = p->ku.multiple.array;
4184 p->ku.multiple.array = NULL;
4185 p->ku.apply.tail_num_rands = n;
4186 p->ku.apply.tail_rands = a;
4187 } else {
4188 p->ku.apply.tail_num_rands = 1;
4189 p->ku.apply.tail_rands = p->tail_buffer;
4190 p->ku.apply.tail_rands[0] = v;
4191 }
4192
4193 p->ku.apply.tail_rator = argv[1];
4194
4195 return SCHEME_TAIL_CALL_WAITING;
4196 }
4197
values_slow(int argc,Scheme_Object * argv[])4198 static MZ_INLINE Scheme_Object *values_slow(int argc, Scheme_Object *argv[])
4199 {
4200 Scheme_Thread *p = scheme_current_thread;
4201 Scheme_Object **a;
4202 int i;
4203
4204 a = MALLOC_N(Scheme_Object *, argc);
4205 p->values_buffer = a;
4206 p->values_buffer_size = argc;
4207
4208 p->ku.multiple.array = a;
4209
4210 for (i = 0; i < argc; i++) {
4211 a[i] = argv[i];
4212 }
4213
4214 return SCHEME_MULTIPLE_VALUES;
4215 }
4216
scheme_values(int argc,Scheme_Object * argv[])4217 Scheme_Object *scheme_values(int argc, Scheme_Object *argv[])
4218 {
4219 Scheme_Thread *p;
4220 int i;
4221 Scheme_Object **a;
4222
4223 if (argc == 1)
4224 return argv[0];
4225
4226 p = scheme_current_thread;
4227 p->ku.multiple.count = argc;
4228 if (p->values_buffer && (p->values_buffer_size >= argc)) {
4229 a = p->values_buffer;
4230 } else {
4231 return values_slow(argc, argv);
4232 }
4233
4234 p->ku.multiple.array = a;
4235
4236 for (i = 0; i < argc; i++) {
4237 a[i] = argv[i];
4238 }
4239
4240 return SCHEME_MULTIPLE_VALUES;
4241 }
4242
scheme_detach_multple_array(Scheme_Object ** values)4243 void scheme_detach_multple_array(Scheme_Object **values)
4244 {
4245 Scheme_Thread *t = scheme_current_thread;
4246
4247 if (SAME_OBJ(values, t->values_buffer))
4248 t->values_buffer = NULL;
4249 }
4250
4251 /*========================================================================*/
4252 /* continuations */
4253 /*========================================================================*/
4254
reset_cjs(Scheme_Continuation_Jump_State * a)4255 static void reset_cjs(Scheme_Continuation_Jump_State *a)
4256 {
4257 a->jumping_to_continuation = NULL;
4258 a->alt_full_continuation = NULL;
4259 a->val = NULL;
4260 a->num_vals = 0;
4261 a->is_kill = 0;
4262 a->is_escape = 0;
4263 a->skip_dws = 0;
4264 }
4265
scheme_clear_escape(void)4266 void scheme_clear_escape(void)
4267 {
4268 Scheme_Thread *p = scheme_current_thread;
4269
4270 reset_cjs(&p->cjs);
4271 p->suspend_break = 0;
4272 }
4273
copy_cjs(Scheme_Continuation_Jump_State * a,Scheme_Continuation_Jump_State * b)4274 static void copy_cjs(Scheme_Continuation_Jump_State *a, Scheme_Continuation_Jump_State *b)
4275 {
4276 a->jumping_to_continuation = b->jumping_to_continuation;
4277 a->alt_full_continuation = b->alt_full_continuation;
4278 a->val = b->val;
4279 a->num_vals = b->num_vals;
4280 a->is_kill = b->is_kill;
4281 a->is_escape = b->is_escape;
4282 a->skip_dws = b->skip_dws;
4283 }
4284
4285 Scheme_Object *
do_call_ec(int argc,Scheme_Object * argv[],Scheme_Object * _for_cc)4286 do_call_ec (int argc, Scheme_Object *argv[], Scheme_Object *_for_cc)
4287 {
4288 mz_jmp_buf newbuf;
4289 Scheme_Escaping_Cont * volatile cont;
4290 Scheme_Thread *p1 = scheme_current_thread;
4291 Scheme_Object * volatile v;
4292 Scheme_Object *a[1];
4293 Scheme_Cont_Frame_Data cframe;
4294 Scheme_Prompt *barrier_prompt;
4295 Scheme_Object * volatile for_cc = _for_cc;
4296
4297 cont = MALLOC_ONE_TAGGED(Scheme_Escaping_Cont);
4298 cont->so.type = scheme_escaping_cont_type;
4299 ASSERT_SUSPEND_BREAK_ZERO();
4300
4301 cont->saveerr = p1->error_buf;
4302 p1->error_buf = &newbuf;
4303 cont->myerr = &newbuf;
4304
4305 scheme_save_env_stack_w_thread(cont->envss, p1);
4306
4307 barrier_prompt = scheme_get_barrier_prompt(NULL, NULL);
4308 cont->barrier_prompt = barrier_prompt;
4309
4310 scheme_prompt_capture_count++;
4311
4312 if (!for_cc)
4313 scheme_push_continuation_frame(&cframe);
4314 scheme_set_cont_mark((Scheme_Object *)cont, scheme_true);
4315
4316 if (scheme_setjmp(newbuf)) {
4317 Scheme_Thread *p2 = scheme_current_thread;
4318 if (p2->cjs.jumping_to_continuation
4319 && SAME_OBJ(p2->cjs.jumping_to_continuation, (Scheme_Object *)cont)) {
4320 Scheme_Object *alt_cont;
4321 int n;
4322
4323 alt_cont = p2->cjs.alt_full_continuation;
4324 if (alt_cont && !((Scheme_Cont *)alt_cont)->orig_escape_cont) {
4325 /* The escape continuation does not exactly match the target
4326 continuation; the fll continuation was just re-using an
4327 existing escape continuation. Now that there's no barrier
4328 in the way, jump to the full continuation. */
4329 return jump_to_alt_continuation();
4330 }
4331
4332 n = p2->cjs.num_vals;
4333 v = p2->cjs.val;
4334 reset_cjs(&p2->cjs);
4335 scheme_restore_env_stack_w_thread(cont->envss, p2);
4336 p2->suspend_break = 0;
4337 scheme_check_break_now();
4338 if (n != 1)
4339 v = scheme_values(n, (Scheme_Object **)v);
4340 else if (v && SAME_TYPE(SCHEME_TYPE(v), scheme_thunk_for_continue_type))
4341 v = _scheme_apply_multi(SCHEME_PTR_VAL(v), 0, NULL);
4342 } else {
4343 scheme_longjmp(*cont->saveerr, 1);
4344 }
4345 } else if (for_cc) {
4346 ((Scheme_Cont *)for_cc)->escape_cont = (Scheme_Object *)cont;
4347 ((Scheme_Cont *)for_cc)->orig_escape_cont = 1;
4348 a[0] = (Scheme_Object *)for_cc;
4349 MZ_CONT_MARK_POS -= 2;
4350 v = _scheme_apply_multi(argv[0], 1, a);
4351 MZ_CONT_MARK_POS += 2;
4352 } else {
4353 a[0] = (Scheme_Object *)cont;
4354 v = _scheme_apply_multi(argv[0], 1, a);
4355 }
4356
4357 p1 = scheme_current_thread;
4358
4359 p1->error_buf = cont->saveerr;
4360 if (!for_cc)
4361 scheme_pop_continuation_frame(&cframe);
4362
4363 return v;
4364 }
4365
4366 Scheme_Object *
scheme_call_ec(int argc,Scheme_Object * argv[])4367 scheme_call_ec (int argc, Scheme_Object *argv[])
4368 {
4369 scheme_check_proc_arity("call-with-escape-continuation", 1,
4370 0, argc, argv);
4371
4372 return do_call_ec(argc, argv, NULL);
4373 }
4374
scheme_escape_continuation_ok(Scheme_Object * ec)4375 int scheme_escape_continuation_ok(Scheme_Object *ec)
4376 {
4377 Scheme_Escaping_Cont *cont = (Scheme_Escaping_Cont *)ec;
4378
4379 if (scheme_extract_one_cc_mark(NULL, (Scheme_Object *)cont))
4380 return 1;
4381 else
4382 return 0;
4383 }
4384
make_continuation_mark_key(int argc,Scheme_Object * argv[])4385 static Scheme_Object *make_continuation_mark_key (int argc, Scheme_Object *argv[])
4386 {
4387 Scheme_Object *o;
4388
4389 if (argc && !SCHEME_SYMBOLP(argv[0]))
4390 scheme_wrong_contract("make-continuation-mark-key", "symbol?", 0, argc, argv);
4391
4392 o = scheme_alloc_small_object();
4393 o->type = scheme_continuation_mark_key_type;
4394 SCHEME_PTR_VAL(o) = (argc ? argv[0] : NULL);
4395
4396 return o;
4397 }
4398
continuation_mark_key_p(int argc,Scheme_Object * argv[])4399 static Scheme_Object *continuation_mark_key_p (int argc, Scheme_Object *argv[])
4400 {
4401 return (SCHEME_CHAPERONE_CONTINUATION_MARK_KEYP(argv[0])
4402 ? scheme_true
4403 : scheme_false);
4404 }
4405
scheme_chaperone_do_continuation_mark(const char * name,int is_get,Scheme_Object * key,Scheme_Object * val)4406 Scheme_Object *scheme_chaperone_do_continuation_mark (const char *name, int is_get, Scheme_Object *key, Scheme_Object *val)
4407 {
4408 Scheme_Chaperone *px;
4409 Scheme_Object *proc;
4410 Scheme_Object *a[1];
4411
4412 while (1) {
4413 if (SCHEME_CONTINUATION_MARK_KEYP(key)) {
4414 return val;
4415 } else {
4416 px = (Scheme_Chaperone *)key;
4417 key = px->prev;
4418
4419 if (is_get)
4420 proc = SCHEME_CAR(px->redirects);
4421 else
4422 proc = SCHEME_CDR(px->redirects);
4423
4424 a[0] = val;
4425 val = _scheme_apply(proc, 1, a);
4426
4427 if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) {
4428 if (!scheme_chaperone_of(val, a[0]))
4429 scheme_wrong_chaperoned(name, "value", a[0], val);
4430 }
4431 }
4432 }
4433 }
4434
do_chaperone_continuation_mark_key(const char * name,int is_impersonator,int argc,Scheme_Object ** argv)4435 Scheme_Object *do_chaperone_continuation_mark_key (const char *name, int is_impersonator, int argc, Scheme_Object **argv)
4436 {
4437 Scheme_Chaperone *px;
4438 Scheme_Object *val = argv[0];
4439 Scheme_Object *redirects;
4440 Scheme_Object *props;
4441
4442 if (SCHEME_CHAPERONEP(val))
4443 val = SCHEME_CHAPERONE_VAL(val);
4444
4445 if (!SCHEME_CONTINUATION_MARK_KEYP(val))
4446 scheme_wrong_contract(name, "continuation-mark-key?", 0, argc, argv);
4447
4448 scheme_check_proc_arity(name, 1, 1, argc, argv);
4449 scheme_check_proc_arity(name, 1, 2, argc, argv);
4450
4451 redirects = scheme_make_pair(argv[1], argv[2]);
4452
4453 props = scheme_parse_chaperone_props(name, 3, argc, argv);
4454
4455 px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
4456 px->iso.so.type = scheme_chaperone_type;
4457 px->val = val;
4458 px->prev = argv[0];
4459 px->props = props;
4460 px->redirects = redirects;
4461
4462 if (is_impersonator)
4463 SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;
4464
4465 return (Scheme_Object *)px;
4466 }
4467
chaperone_continuation_mark_key(int argc,Scheme_Object ** argv)4468 static Scheme_Object *chaperone_continuation_mark_key(int argc, Scheme_Object **argv)
4469 {
4470 return do_chaperone_continuation_mark_key("chaperone-continuation-mark-key", 0, argc, argv);
4471 }
4472
impersonate_continuation_mark_key(int argc,Scheme_Object ** argv)4473 static Scheme_Object *impersonate_continuation_mark_key(int argc, Scheme_Object **argv)
4474 {
4475 return do_chaperone_continuation_mark_key("impersonate-continuation-mark-key", 1, argc, argv);
4476 }
4477
scheme_get_immediate_cc_mark(Scheme_Object * key,Scheme_Object * def_val)4478 Scheme_Object *scheme_get_immediate_cc_mark(Scheme_Object *key, Scheme_Object *def_val)
4479 {
4480 Scheme_Thread *p = scheme_current_thread;
4481 intptr_t findpos, bottom;
4482
4483 if (p->cont_mark_stack_segments) {
4484 findpos = (intptr_t)MZ_CONT_MARK_STACK;
4485 bottom = (intptr_t)p->cont_mark_stack_bottom;
4486 while (findpos-- > bottom) {
4487 Scheme_Cont_Mark *seg = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE];
4488 intptr_t pos = findpos & SCHEME_MARK_SEGMENT_MASK;
4489 Scheme_Cont_Mark *find = seg + pos;
4490
4491 if ((intptr_t)find->pos < (intptr_t)MZ_CONT_MARK_POS) {
4492 break;
4493 } else {
4494 if (find->key == key)
4495 return find->val;
4496 }
4497 }
4498 }
4499
4500 return def_val;
4501 }
4502
scheme_chaperone_get_immediate_cc_mark(Scheme_Object * key,Scheme_Object * def_val)4503 Scheme_Object *scheme_chaperone_get_immediate_cc_mark(Scheme_Object *key, Scheme_Object *def_val)
4504 {
4505 Scheme_Object *val;
4506
4507 if (SCHEME_NP_CHAPERONEP(key)
4508 && SCHEME_CONTINUATION_MARK_KEYP(SCHEME_CHAPERONE_VAL(key))) {
4509 val = scheme_get_immediate_cc_mark(SCHEME_CHAPERONE_VAL(key), NULL);
4510 if (val)
4511 return scheme_chaperone_do_continuation_mark("call-with-immediate-continuation-mark",
4512 1, key, val);
4513 else
4514 return def_val;
4515 } else
4516 return scheme_get_immediate_cc_mark(key, def_val);
4517 }
4518
call_with_immediate_cc_mark(int argc,Scheme_Object * argv[])4519 static Scheme_Object *call_with_immediate_cc_mark (int argc, Scheme_Object *argv[])
4520 {
4521 Scheme_Object *a[1], *val;
4522
4523 scheme_check_proc_arity("call-with-immediate-continuation-mark", 1, 1, argc, argv);
4524
4525 val = scheme_chaperone_get_immediate_cc_mark(argv[0], ((argc > 2) ? argv[2] : scheme_false));
4526 a[0] = val;
4527
4528 return scheme_tail_apply(argv[1], 1, a);
4529 }
4530
4531 static Scheme_Object *
do_call_with_sema(const char * who,int enable_break,int argc,Scheme_Object * argv[])4532 do_call_with_sema(const char *who, int enable_break, int argc, Scheme_Object *argv[])
4533 {
4534 mz_jmp_buf newbuf, * volatile savebuf;
4535 Scheme_Prompt * volatile prompt;
4536 int i, just_try;
4537 int volatile extra;
4538 Scheme_Object * volatile sema;
4539 Scheme_Object *v, *quick_args[4], **extra_args;
4540 Scheme_Cont_Frame_Data cframe;
4541 int old_pcc = scheme_prompt_capture_count;
4542
4543 if (!SCHEME_SEMAP(argv[0])) {
4544 scheme_wrong_contract(who, "semaphore?", 0, argc, argv);
4545 return NULL;
4546 }
4547 if (argc > 2)
4548 extra = argc - 3;
4549 else
4550 extra = 0;
4551 if (!scheme_check_proc_arity(NULL, extra, 1, argc, argv)) {
4552 if (!SCHEME_PROCP(argv[1]))
4553 scheme_wrong_contract(who, "procedure?", 1, argc, argv);
4554 else
4555 scheme_contract_error(who, "procedure arity does not match extra-argument count",
4556 "procedure", 1, argv[1],
4557 "extra-argument count", 1, scheme_make_integer(extra),
4558 NULL);
4559 return NULL;
4560 }
4561 if ((argc > 2) && SCHEME_TRUEP(argv[2])) {
4562 if (!scheme_check_proc_arity(NULL, 0, 2, argc, argv)) {
4563 scheme_wrong_contract(who, "(or/c (-> any) #f)", 1, argc, argv);
4564 return NULL;
4565 }
4566 just_try = 1;
4567 } else
4568 just_try = 0;
4569
4570 sema = argv[0];
4571
4572 if (just_try && enable_break && scheme_current_thread->external_break) {
4573 /* Check for a break before polling the semaphore */
4574 Scheme_Cont_Frame_Data bcframe;
4575 scheme_push_break_enable(&bcframe, 1, 1);
4576 scheme_check_break_now();
4577 scheme_pop_break_enable(&bcframe, 0);
4578 }
4579
4580 if (!scheme_wait_sema(sema, just_try ? 1 : (enable_break ? -1 : 0))) {
4581 return _scheme_tail_apply(argv[2], 0, NULL);
4582 }
4583
4584 savebuf = scheme_current_thread->error_buf;
4585 scheme_current_thread->error_buf = &newbuf;
4586
4587 if (available_cws_prompt) {
4588 prompt = available_cws_prompt;
4589 available_cws_prompt = NULL;
4590 } else {
4591 prompt = MALLOC_ONE_TAGGED(Scheme_Prompt);
4592 prompt->so.type = scheme_prompt_type;
4593 }
4594
4595 scheme_push_continuation_frame(&cframe);
4596 scheme_set_cont_mark(barrier_prompt_key, (Scheme_Object *)prompt);
4597
4598 if (scheme_setjmp(newbuf)) {
4599 v = NULL;
4600 } else {
4601 if (extra > 4)
4602 extra_args = MALLOC_N(Scheme_Object *, extra);
4603 else
4604 extra_args = quick_args;
4605 for (i = 3; i < argc; i++) {
4606 extra_args[i - 3] = argv[i];
4607 }
4608
4609 v = _scheme_apply_multi(argv[1], extra, extra_args);
4610 }
4611
4612 scheme_pop_continuation_frame(&cframe);
4613
4614 scheme_post_sema(sema); /* FIXME: what if we reach the max count? */
4615
4616 if (old_pcc != scheme_prompt_capture_count)
4617 available_cws_prompt = prompt;
4618
4619 if (!v)
4620 scheme_longjmp(*savebuf, 1);
4621
4622 scheme_current_thread->error_buf = savebuf;
4623
4624 return v;
4625 }
4626
4627 static Scheme_Object *
call_with_sema(int argc,Scheme_Object * argv[])4628 call_with_sema(int argc, Scheme_Object *argv[])
4629 {
4630 return do_call_with_sema("call-with-semaphore", 0, argc, argv);
4631 }
4632
4633 static Scheme_Object *
call_with_sema_enable_break(int argc,Scheme_Object * argv[])4634 call_with_sema_enable_break(int argc, Scheme_Object *argv[])
4635 {
4636 return do_call_with_sema("call-with-semaphore/enable-break", 1, argc, argv);
4637 }
4638
copy_out_runstack(Scheme_Thread * p,Scheme_Object ** runstack,Scheme_Object ** runstack_start,Scheme_Cont * share_from,Scheme_Prompt * effective_prompt)4639 static Scheme_Saved_Stack *copy_out_runstack(Scheme_Thread *p,
4640 Scheme_Object **runstack,
4641 Scheme_Object **runstack_start,
4642 Scheme_Cont *share_from,
4643 Scheme_Prompt *effective_prompt)
4644 {
4645 Scheme_Saved_Stack *saved, *isaved, *csaved, *share_saved, *share_csaved, *ss;
4646 Scheme_Object **start;
4647 intptr_t size;
4648 int done;
4649
4650 /* Copy out current runstack: */
4651 saved = MALLOC_ONE_RT(Scheme_Saved_Stack);
4652 #ifdef MZTAG_REQUIRED
4653 saved->type = scheme_rt_saved_stack;
4654 #endif
4655 if (share_from && (share_from->runstack_start == runstack_start)) {
4656 intptr_t shared_amt;
4657 /* Copy just the difference between share_from's runstack and current runstack... */
4658 size = (share_from->ss.runstack_offset - (runstack XFORM_OK_MINUS runstack_start));
4659 /* But skip the first few items, which are potentially call/cc's arguments: */
4660 shared_amt = (p->runstack_size - share_from->ss.runstack_offset);
4661 if (shared_amt > MAX_CALL_CC_ARG_COUNT)
4662 size += MAX_CALL_CC_ARG_COUNT;
4663 else
4664 size += shared_amt;
4665 } else if (effective_prompt && (scheme_prompt_runstack_boundary_start(effective_prompt) == runstack_start)) {
4666 /* Copy only up to the prompt */
4667 size = effective_prompt->runstack_boundary_offset - (runstack XFORM_OK_MINUS runstack_start);
4668 } else {
4669 size = p->runstack_size - (runstack XFORM_OK_MINUS runstack_start);
4670 }
4671
4672 MZ_ASSERT(size <= p->runstack_size);
4673
4674 saved->runstack_size = size;
4675 start = MALLOC_N(Scheme_Object*, size);
4676 saved->runstack_start = start;
4677 memcpy(saved->runstack_start, runstack, size * sizeof(Scheme_Object *));
4678 saved->runstack_offset = (runstack XFORM_OK_MINUS runstack_start);
4679
4680 if (!effective_prompt || (scheme_prompt_runstack_boundary_start(effective_prompt) != runstack_start)) {
4681
4682 /* Copy saved runstacks: */
4683 if (share_from) {
4684 /* We can share all saved runstacks */
4685 share_csaved = share_from->runstack_saved;
4686 share_saved = share_from->runstack_copied->prev;
4687 } else {
4688 share_saved = NULL;
4689 share_csaved = NULL;
4690 }
4691 isaved = saved;
4692 for (csaved = p->runstack_saved; csaved; csaved = csaved->prev) {
4693 if (share_csaved && (csaved->runstack_start == share_csaved->runstack_start)) {
4694 /* Share */
4695 isaved->prev = share_saved;
4696 break;
4697 }
4698
4699 ss = MALLOC_ONE_RT(Scheme_Saved_Stack);
4700 #ifdef MZTAG_REQUIRED
4701 ss->type = scheme_rt_saved_stack;
4702 #endif
4703 isaved->prev = ss;
4704 isaved = ss;
4705
4706 if (effective_prompt && (scheme_prompt_runstack_boundary_start(effective_prompt) == csaved->runstack_start)) {
4707 size = effective_prompt->runstack_boundary_offset - csaved->runstack_offset;
4708 done = 1;
4709 } else {
4710 size = csaved->runstack_size - csaved->runstack_offset;
4711 done = 0;
4712 }
4713
4714 isaved->runstack_size = size;
4715
4716 start = MALLOC_N(Scheme_Object*, size);
4717 isaved->runstack_start = start;
4718 memcpy(isaved->runstack_start,
4719 csaved->runstack_start XFORM_OK_PLUS csaved->runstack_offset,
4720 size * sizeof(Scheme_Object *));
4721 isaved->runstack_offset = csaved->runstack_offset;
4722
4723 if (done) break;
4724 }
4725 }
4726
4727 return saved;
4728 }
4729
copy_out_mark_stack(Scheme_Thread * p,MZ_MARK_STACK_TYPE pos,Scheme_Cont * sub_cont,intptr_t * _offset,Scheme_Prompt * effective_prompt,int clear_caches)4730 static Scheme_Cont_Mark *copy_out_mark_stack(Scheme_Thread *p,
4731 MZ_MARK_STACK_TYPE pos,
4732 Scheme_Cont *sub_cont,
4733 intptr_t *_offset,
4734 Scheme_Prompt *effective_prompt,
4735 int clear_caches)
4736 {
4737 intptr_t cmcount, offset = 0, sub_count = 0;
4738 Scheme_Cont_Mark *cont_mark_stack_copied;
4739
4740 /* Copy cont mark stack: */
4741 cmcount = (intptr_t)pos;
4742 offset = 0;
4743
4744 if (sub_cont) {
4745 /* Rely on copy of marks in a tail of this continuation. */
4746 sub_count = sub_cont->cont_mark_total - sub_cont->cont_mark_nonshare;
4747 if (sub_count < 0)
4748 sub_count = 0;
4749 } else if (effective_prompt) {
4750 /* Copy only marks since the prompt. */
4751 sub_count = effective_prompt->mark_boundary;
4752 }
4753 cmcount -= sub_count;
4754 offset += sub_count;
4755
4756 if (_offset) *_offset = offset;
4757
4758 if (cmcount) {
4759 cont_mark_stack_copied = MALLOC_N(Scheme_Cont_Mark, cmcount);
4760 while (cmcount--) {
4761 int cms = cmcount + offset;
4762 Scheme_Cont_Mark *seg = p->cont_mark_stack_segments[cms >> SCHEME_LOG_MARK_SEGMENT_SIZE];
4763 intptr_t pos = cms & SCHEME_MARK_SEGMENT_MASK;
4764 Scheme_Cont_Mark *cm = seg + pos;
4765
4766 memcpy(cont_mark_stack_copied + cmcount, cm, sizeof(Scheme_Cont_Mark));
4767 if (clear_caches)
4768 cont_mark_stack_copied[cmcount].cache = NULL;
4769 }
4770
4771 return cont_mark_stack_copied;
4772 } else
4773 return NULL;
4774 }
4775
copy_in_runstack(Scheme_Thread * p,Scheme_Saved_Stack * isaved,int set_runstack)4776 static void copy_in_runstack(Scheme_Thread *p, Scheme_Saved_Stack *isaved, int set_runstack)
4777 {
4778 Scheme_Saved_Stack *csaved;
4779 intptr_t size;
4780
4781 size = isaved->runstack_size;
4782 if (set_runstack) {
4783 MZ_RUNSTACK = MZ_RUNSTACK_START + (p->runstack_size - size);
4784 }
4785 memcpy(MZ_RUNSTACK, isaved->runstack_start, size * sizeof(Scheme_Object *));
4786 for (csaved = p->runstack_saved; csaved; csaved = csaved->prev) {
4787 isaved = isaved->prev;
4788 if (!isaved) {
4789 /* The saved stack can be shorter than the current stack if
4790 there's a barrier prompt, or if we're in shortcut mode. */
4791 break;
4792 }
4793 size = isaved->runstack_size;
4794 csaved->runstack_offset = isaved->runstack_offset;
4795 memcpy(csaved->runstack_start XFORM_OK_PLUS csaved->runstack_offset,
4796 isaved->runstack_start,
4797 size * sizeof(Scheme_Object *));
4798 }
4799 }
4800
copy_in_mark_stack(Scheme_Thread * p,Scheme_Cont_Mark * cont_mark_stack_copied,MZ_MARK_STACK_TYPE cms,MZ_MARK_STACK_TYPE base_cms,intptr_t copied_offset,Scheme_Object ** _sub_conts,int clear_caches,MZ_MARK_POS_TYPE new_mark_pos)4801 static void copy_in_mark_stack(Scheme_Thread *p, Scheme_Cont_Mark *cont_mark_stack_copied,
4802 MZ_MARK_STACK_TYPE cms, MZ_MARK_STACK_TYPE base_cms,
4803 intptr_t copied_offset, Scheme_Object **_sub_conts,
4804 int clear_caches,
4805 MZ_MARK_POS_TYPE new_mark_pos)
4806 /* Copies in the mark stack up to depth cms, but assumes that the
4807 stack up to depth base_cms is already in place (probably in
4808 place for a dynamic-wind context in an continuation
4809 restoration.) */
4810 {
4811 intptr_t cmcount, base_cmcount, cmoffset;
4812 Scheme_Cont_Mark *cm_src;
4813 Scheme_Cont *sub_cont = NULL;
4814
4815 cmcount = (intptr_t)cms;
4816 base_cmcount = (intptr_t)base_cms;
4817
4818 if (cmcount) {
4819 /* First, make sure we have enough segments */
4820 intptr_t needed = ((cmcount - 1) >> SCHEME_LOG_MARK_SEGMENT_SIZE) + 1;
4821
4822 if (needed > p->cont_mark_seg_count) {
4823 Scheme_Cont_Mark **segs, **old_segs = p->cont_mark_stack_segments;
4824 int newcount = needed, oldcount = p->cont_mark_seg_count, npos;
4825
4826 /* Note: we perform allocations before changing p to avoid GC trouble,
4827 since Racket adjusts a thread's cont_mark_stack_segments on GC. */
4828 segs = MALLOC_N(Scheme_Cont_Mark *, needed);
4829
4830 for (npos = needed; npos--; ) {
4831 if (npos < oldcount)
4832 segs[npos] = old_segs[npos]; /* might be NULL due to GC! */
4833 else
4834 segs[npos] = NULL;
4835
4836 if (!segs[npos]) {
4837 Scheme_Cont_Mark *cm;
4838 cm = scheme_malloc_allow_interior(sizeof(Scheme_Cont_Mark) * SCHEME_MARK_SEGMENT_SIZE);
4839 segs[npos] = cm;
4840 }
4841 }
4842
4843 p->cont_mark_seg_count = newcount;
4844 p->cont_mark_stack_segments = segs;
4845 }
4846 }
4847
4848 /* Updated after potential GC: */
4849 MZ_CONT_MARK_POS = new_mark_pos;
4850 MZ_CONT_MARK_STACK = cms;
4851
4852 if (_sub_conts) {
4853 if (*_sub_conts) {
4854 sub_cont = (Scheme_Cont *)SCHEME_CAR(*_sub_conts);
4855 }
4856 }
4857
4858 while (base_cmcount < cmcount) {
4859 Scheme_Cont_Mark *seg = p->cont_mark_stack_segments[base_cmcount >> SCHEME_LOG_MARK_SEGMENT_SIZE];
4860 intptr_t pos = base_cmcount & SCHEME_MARK_SEGMENT_MASK;
4861 GC_CAN_IGNORE Scheme_Cont_Mark *cm = seg + pos;
4862
4863 cm_src = cont_mark_stack_copied;
4864 cmoffset = base_cmcount - copied_offset;
4865
4866 if (sub_cont) {
4867 while (base_cmcount >= (sub_cont->cont_mark_total - sub_cont->cont_mark_nonshare)) {
4868 *_sub_conts = SCHEME_CDR(*_sub_conts);
4869 if (*_sub_conts) {
4870 sub_cont = (Scheme_Cont *)SCHEME_CAR(*_sub_conts);
4871 } else {
4872 sub_cont = NULL;
4873 break;
4874 }
4875 }
4876 if (sub_cont) {
4877 cm_src = sub_cont->cont_mark_stack_copied;
4878 cmoffset = base_cmcount - sub_cont->cont_mark_offset;
4879 }
4880 }
4881
4882 memcpy(cm, cm_src + cmoffset, sizeof(Scheme_Cont_Mark));
4883 if (clear_caches) {
4884 cm->cache = NULL;
4885 }
4886
4887 base_cmcount++;
4888 }
4889 }
4890
find_shareable_marks()4891 static MZ_MARK_STACK_TYPE find_shareable_marks()
4892 {
4893 Scheme_Thread *p = scheme_current_thread;
4894 intptr_t cmcount, delta = 0;
4895
4896 cmcount = (intptr_t)MZ_CONT_MARK_STACK;
4897
4898 while (cmcount--) {
4899 Scheme_Cont_Mark *seg = p->cont_mark_stack_segments[cmcount >> SCHEME_LOG_MARK_SEGMENT_SIZE];
4900 intptr_t pos = cmcount & SCHEME_MARK_SEGMENT_MASK;
4901
4902 if (seg[pos].pos < MZ_CONT_MARK_POS)
4903 break;
4904
4905 /* If a key is cont_key or scheme_stack_dump_key, then treat it
4906 as sharable, because we don't mind if a new continuation gets
4907 the old value. */
4908 if (SAME_OBJ(seg[pos].key, cont_key))
4909 delta++;
4910 else if (SAME_OBJ(seg[pos].key, scheme_stack_dump_key))
4911 delta++;
4912 else
4913 delta = 0;
4914 }
4915
4916 return cmcount + 1 + delta;
4917 }
4918
clone_overflows(Scheme_Overflow * overflow,void * limit,Scheme_Overflow * tail)4919 static Scheme_Overflow *clone_overflows(Scheme_Overflow *overflow, void *limit, Scheme_Overflow *tail)
4920 {
4921 Scheme_Overflow *naya, *first = NULL, *prev = NULL;
4922 int stop = 0;
4923
4924 for (; overflow && !stop; overflow = overflow->prev) {
4925 naya = MALLOC_ONE_RT(Scheme_Overflow);
4926 memcpy(naya, overflow, sizeof(Scheme_Overflow));
4927 if (prev)
4928 prev->prev = naya;
4929 else
4930 first = naya;
4931 prev = naya;
4932 if (limit && overflow->id == limit)
4933 stop = 1;
4934 }
4935
4936 if (first) {
4937 prev->prev = tail;
4938 return first;
4939 } else
4940 return tail;
4941 }
4942
clone_dyn_wind(Scheme_Dynamic_Wind * dw,Scheme_Object * limit_prompt_tag,int limit_depth,int limit_count,Scheme_Dynamic_Wind * tail,int keep_tail,int composable)4943 static Scheme_Dynamic_Wind *clone_dyn_wind(Scheme_Dynamic_Wind *dw,
4944 Scheme_Object *limit_prompt_tag, int limit_depth, int limit_count,
4945 Scheme_Dynamic_Wind *tail,
4946 int keep_tail, int composable)
4947 {
4948 Scheme_Dynamic_Wind *naya, *first = NULL, *prev = NULL;
4949 int cnt = 0;
4950
4951 for (; dw; dw = dw->prev) {
4952 if (dw->depth == limit_depth)
4953 break;
4954 if (composable && limit_prompt_tag && (dw->prompt_tag == limit_prompt_tag))
4955 break;
4956 if (cnt == limit_count)
4957 break;
4958 scheme_ensure_dw_id(dw);
4959 naya = MALLOC_ONE_RT(Scheme_Dynamic_Wind);
4960 memcpy(naya, dw, sizeof(Scheme_Dynamic_Wind));
4961 if (prev)
4962 prev->prev = naya;
4963 else
4964 first = naya;
4965 prev = naya;
4966 cnt++;
4967 if (limit_prompt_tag && (dw->prompt_tag == limit_prompt_tag)) {
4968 dw = dw->prev; /* in case keep_tail is true */
4969 break;
4970 }
4971 }
4972 if (keep_tail)
4973 tail = dw;
4974 if (first) {
4975 prev->prev = tail;
4976 if (tail)
4977 cnt += tail->depth + 1;
4978 for (dw = first; dw != tail; dw = dw->prev) {
4979 dw->depth = --cnt;
4980 }
4981 return first;
4982 } else
4983 return tail;
4984 }
4985
clear_cm_copy_caches(Scheme_Cont_Mark * cp,int cnt)4986 static void clear_cm_copy_caches(Scheme_Cont_Mark *cp, int cnt)
4987 {
4988 int i;
4989 for (i = 0; i < cnt; i++) {
4990 cp[i].cache = NULL;
4991 }
4992 }
4993
clone_runstack_saved(Scheme_Saved_Stack * saved,Scheme_Object ** boundary_start,Scheme_Saved_Stack * last)4994 static Scheme_Saved_Stack *clone_runstack_saved(Scheme_Saved_Stack *saved, Scheme_Object **boundary_start,
4995 Scheme_Saved_Stack *last)
4996 {
4997 Scheme_Saved_Stack *naya, *first = last, *prev = NULL;
4998
4999 while (saved) {
5000 naya = MALLOC_ONE_RT(Scheme_Saved_Stack);
5001 memcpy(naya, saved, sizeof(Scheme_Saved_Stack));
5002 if (prev)
5003 prev->prev = naya;
5004 else
5005 first = naya;
5006 prev = naya;
5007 if (saved->runstack_start == boundary_start)
5008 break;
5009 saved = saved->prev;
5010 }
5011 if (prev)
5012 prev->prev = last;
5013
5014 return first;
5015 }
5016
clone_runstack_copied(Scheme_Saved_Stack * copied,Scheme_Object ** copied_start,Scheme_Saved_Stack * saved,Scheme_Object ** boundary_start,intptr_t boundary_offset)5017 static Scheme_Saved_Stack *clone_runstack_copied(Scheme_Saved_Stack *copied,
5018 Scheme_Object **copied_start,
5019 Scheme_Saved_Stack *saved,
5020 Scheme_Object **boundary_start,
5021 intptr_t boundary_offset)
5022 {
5023 Scheme_Saved_Stack *naya, *first = NULL, *prev = NULL, *s;
5024
5025 if (copied_start == boundary_start) {
5026 naya = copied;
5027 } else {
5028 for (naya = copied->prev, s = saved;
5029 s->runstack_start != boundary_start;
5030 naya = naya->prev, s = s->prev) {
5031 }
5032 }
5033 if ((naya->runstack_offset + naya->runstack_size == boundary_offset)
5034 && !naya->prev) {
5035 /* no need to prune anything */
5036 return copied;
5037 }
5038
5039 s = NULL;
5040 while (copied) {
5041 naya = MALLOC_ONE_RT(Scheme_Saved_Stack);
5042 memcpy(naya, copied, sizeof(Scheme_Saved_Stack));
5043 naya->prev = NULL;
5044 if (prev)
5045 prev->prev = naya;
5046 else
5047 first = naya;
5048 prev = naya;
5049 if ((!s && copied_start == boundary_start)
5050 || (s && (s->runstack_start == boundary_start))) {
5051 intptr_t size;
5052 Scheme_Object **a;
5053 size = boundary_offset - naya->runstack_offset;
5054 if (size < 0)
5055 scheme_signal_error("negative stack-copy size while pruning");
5056 if (size > naya->runstack_size)
5057 scheme_signal_error("bigger stack-copy size while pruning: %d vs. %d", size, naya->runstack_size);
5058 a = MALLOC_N(Scheme_Object *, size);
5059 memcpy(a, naya->runstack_start, size * sizeof(Scheme_Object *));
5060 naya->runstack_start = a;
5061 naya->runstack_size = size;
5062 break;
5063 }
5064
5065 copied = copied->prev;
5066 if (!s)
5067 s = saved;
5068 else
5069 s = s->prev;
5070 }
5071
5072 return first;
5073 }
5074
clone_meta_cont(Scheme_Meta_Continuation * mc,Scheme_Object * limit_tag,int limit_depth,Scheme_Meta_Continuation * prompt_cont,Scheme_Prompt * prompt,Scheme_Meta_Continuation * tail,int for_composable)5075 static Scheme_Meta_Continuation *clone_meta_cont(Scheme_Meta_Continuation *mc,
5076 Scheme_Object *limit_tag, int limit_depth,
5077 Scheme_Meta_Continuation *prompt_cont,
5078 Scheme_Prompt *prompt,
5079 Scheme_Meta_Continuation *tail,
5080 int for_composable)
5081 {
5082 Scheme_Meta_Continuation *naya, *first = NULL, *prev = NULL;
5083 int cnt = 0, depth;
5084
5085 for (; mc; mc = mc->next) {
5086 if (!limit_depth--)
5087 break;
5088 if (!mc->pseudo && SAME_OBJ(mc->prompt_tag, limit_tag))
5089 break;
5090 if (for_composable && mc->pseudo && mc->empty_to_next && mc->next
5091 && SAME_OBJ(mc->next->prompt_tag, limit_tag)) {
5092 /* We don't need to keep the compose-introduced
5093 meta-continuation, because it represents an empty
5094 continuation relative to the prompt. */
5095 break;
5096 }
5097
5098 naya = MALLOC_ONE_RT(Scheme_Meta_Continuation);
5099 cnt++;
5100 memcpy(naya, mc, sizeof(Scheme_Meta_Continuation));
5101 if (SAME_OBJ(mc, prompt_cont)) {
5102 /* Need only part of this meta-continuation's marks. */
5103 intptr_t delta;
5104 void *stack_boundary;
5105
5106 delta = prompt->mark_boundary - naya->cont_mark_offset;
5107 if (delta) {
5108 naya->cont_mark_total -= delta;
5109 naya->cont_mark_offset += delta;
5110 if (naya->cont_mark_total) {
5111 Scheme_Cont_Mark *cp;
5112 cp = MALLOC_N(Scheme_Cont_Mark, naya->cont_mark_total);
5113 memcpy(cp, mc->cont_mark_stack_copied + delta, naya->cont_mark_total * sizeof(Scheme_Cont_Mark));
5114 if (mc->cm_caches) {
5115 clear_cm_copy_caches(cp, naya->cont_mark_total);
5116 }
5117 naya->cont_mark_stack_copied = cp;
5118 naya->cm_caches = 0;
5119 naya->cm_shared = 0;
5120 } else
5121 naya->cont_mark_stack_copied = NULL;
5122 }
5123 naya->cont_mark_pos_bottom = prompt->boundary_mark_pos;
5124
5125 if ((prompt->boundary_overflow_id && (prompt->boundary_overflow_id == naya->overflow->id))
5126 || (!prompt->boundary_overflow_id && !naya->overflow->prev)) {
5127 stack_boundary = prompt->stack_boundary;
5128 } else {
5129 stack_boundary = naya->overflow->stack_start;
5130 }
5131
5132 if (naya->cont) {
5133 Scheme_Cont *cnaya;
5134 Scheme_Saved_Stack *saved;
5135
5136 cnaya = MALLOC_ONE_TAGGED(Scheme_Cont);
5137 memcpy(cnaya, naya->cont, sizeof(Scheme_Cont));
5138
5139 naya->cont = cnaya;
5140
5141 cnaya->cont_mark_total = naya->cont_mark_total;
5142 cnaya->cont_mark_offset = naya->cont_mark_offset;
5143 cnaya->cont_mark_pos_bottom = naya->cont_mark_pos_bottom;
5144 cnaya->cont_mark_stack_copied = naya->cont_mark_stack_copied;
5145
5146 cnaya->prompt_stack_start = stack_boundary;
5147
5148 /* Prune unneeded runstack data */
5149 saved = clone_runstack_copied(cnaya->runstack_copied,
5150 cnaya->runstack_start,
5151 cnaya->runstack_saved,
5152 scheme_prompt_runstack_boundary_start(prompt),
5153 prompt->runstack_boundary_offset);
5154 cnaya->runstack_copied = saved;
5155
5156 /* Prune unneeded buffers */
5157 if (scheme_prompt_runstack_boundary_start(prompt) == cnaya->runstack_start)
5158 saved = NULL;
5159 else
5160 saved = clone_runstack_saved(cnaya->runstack_saved,
5161 scheme_prompt_runstack_boundary_start(prompt),
5162 NULL);
5163 cnaya->runstack_saved = saved;
5164
5165 cnaya->need_meta_prompt = 1;
5166 }
5167 if (naya->overflow && !naya->overflow->eot) {
5168 /* Prune unneeded C-stack data */
5169 Scheme_Overflow *onaya;
5170 Scheme_Overflow_Jmp *jmp;
5171 jmp = scheme_prune_jmpup(naya->overflow->jmp, stack_boundary);
5172 if (jmp) {
5173 onaya = MALLOC_ONE_RT(Scheme_Overflow);
5174 memcpy(onaya, naya->overflow, sizeof(Scheme_Overflow));
5175 naya->overflow = onaya;
5176 onaya->jmp = jmp;
5177 onaya->stack_start = stack_boundary;
5178 }
5179 }
5180 } else {
5181 if (!mc->cm_caches) {
5182 mc->cm_shared = 1;
5183 naya->cm_shared = 1;
5184 } else {
5185 Scheme_Cont_Mark *cp;
5186 cp = MALLOC_N(Scheme_Cont_Mark, naya->cont_mark_total);
5187 if (naya->cont_mark_total)
5188 memcpy(cp, mc->cont_mark_stack_copied, naya->cont_mark_total * sizeof(Scheme_Cont_Mark));
5189 clear_cm_copy_caches(cp, naya->cont_mark_total);
5190 naya->cont_mark_stack_copied = cp;
5191 naya->cm_caches = 0;
5192 naya->cm_shared = 0;
5193 }
5194 }
5195 if (prev)
5196 prev->next = naya;
5197 else
5198 first = naya;
5199 prev = naya;
5200 }
5201
5202 if (first) {
5203 prev->next = tail;
5204 } else
5205 first = tail;
5206
5207 /* Set depth for newly prefixed meta-conts: */
5208 if (tail)
5209 depth = tail->depth + 1;
5210 else
5211 depth = 0;
5212 for (naya = first; cnt--; naya = naya->next) {
5213 naya->depth = depth + cnt;
5214 }
5215
5216 return first;
5217 }
5218
sync_meta_cont(Scheme_Meta_Continuation * resume_mc)5219 static void sync_meta_cont(Scheme_Meta_Continuation *resume_mc)
5220 {
5221 Scheme_Cont *cnaya;
5222
5223 if (!resume_mc->cont)
5224 return;
5225
5226 cnaya = MALLOC_ONE_TAGGED(Scheme_Cont);
5227 memcpy(cnaya, resume_mc->cont, sizeof(Scheme_Cont));
5228
5229 resume_mc->cont = cnaya;
5230
5231 cnaya->ss.cont_mark_stack += (resume_mc->cont_mark_total - cnaya->cont_mark_total);
5232
5233 cnaya->cont_mark_total = resume_mc->cont_mark_total;
5234 cnaya->cont_mark_offset = resume_mc->cont_mark_offset;
5235 cnaya->cont_mark_pos_bottom = resume_mc->cont_mark_pos_bottom;
5236 cnaya->cont_mark_stack_copied = resume_mc->cont_mark_stack_copied;
5237 }
5238
prune_cont_marks(Scheme_Meta_Continuation * resume_mc,Scheme_Cont * cont,Scheme_Object * extra_marks)5239 void prune_cont_marks(Scheme_Meta_Continuation *resume_mc, Scheme_Cont *cont, Scheme_Object *extra_marks)
5240 {
5241 Scheme_Object *val;
5242 Scheme_Hash_Table *ht;
5243 intptr_t pos, num_overlap, num_coverlap, new_overlap, base, i;
5244 Scheme_Cont_Mark *cp;
5245
5246 for (pos = resume_mc->cont_mark_total, num_overlap = 0;
5247 pos--;
5248 num_overlap++) {
5249 if (resume_mc->cont_mark_stack_copied[pos].pos != resume_mc->cont_mark_pos)
5250 break;
5251 }
5252
5253 if (!num_overlap && (!extra_marks || !SCHEME_VEC_SIZE(extra_marks))) {
5254 /* No pruning (nothing to prune) or addition needed. */
5255 return;
5256 }
5257
5258 for (pos = 0, num_coverlap = 0;
5259 pos < cont->cont_mark_total;
5260 num_coverlap++, pos++) {
5261 if (cont->cont_mark_stack_copied[pos].pos != (cont->cont_mark_pos_bottom + 2))
5262 break;
5263 }
5264
5265 if (!num_coverlap && (!extra_marks || !SCHEME_VEC_SIZE(extra_marks))) {
5266 /* No pruning (nothing to compare against) or addition needed. */
5267 return;
5268 }
5269
5270 /* Compute the new set to have in the meta-continuation. */
5271 ht = scheme_make_hash_table(SCHEME_hash_ptr);
5272
5273 for (pos = resume_mc->cont_mark_total - 1, i = 0; i < num_overlap; i++, pos--) {
5274 val = resume_mc->cont_mark_stack_copied[pos].val;
5275 if (!val)
5276 val = cont_key;
5277 scheme_hash_set(ht,
5278 resume_mc->cont_mark_stack_copied[pos].key,
5279 val);
5280 }
5281 if (extra_marks) {
5282 for (i = 0; i < SCHEME_VEC_SIZE(extra_marks); i += 2) {
5283 val = SCHEME_VEC_ELS(extra_marks)[i+1];
5284 if (!val)
5285 val = cont_key;
5286 scheme_hash_set(ht, SCHEME_VEC_ELS(extra_marks)[i], val);
5287 }
5288 }
5289 for (pos = 0, i = 0; i < num_coverlap; i++, pos++) {
5290 scheme_hash_set(ht,
5291 cont->cont_mark_stack_copied[pos].key,
5292 NULL);
5293 }
5294
5295 new_overlap = ht->count;
5296
5297 /* Install changes: */
5298 base = resume_mc->cont_mark_total - num_overlap;
5299 cp = MALLOC_N(Scheme_Cont_Mark, base + new_overlap);
5300 memcpy(cp, resume_mc->cont_mark_stack_copied, base * sizeof(Scheme_Cont_Mark));
5301 resume_mc->cont_mark_stack_copied = cp;
5302 resume_mc->cont_mark_total = base + new_overlap;
5303 resume_mc->cm_shared = 0;
5304 resume_mc->cont_mark_stack += (new_overlap - num_overlap);
5305 for (i = 0; i < ht->size; i++) {
5306 if (ht->vals[i]) {
5307 cp[base].key = ht->keys[i];
5308 val = ht->vals[i];
5309 if (SAME_OBJ(val, cont_key))
5310 val = NULL;
5311 cp[base].val = val;
5312 cp[base].pos = resume_mc->cont_mark_pos;
5313 cp[base].cache = NULL;
5314 base++;
5315 }
5316 }
5317
5318 sync_meta_cont(resume_mc);
5319 }
5320
exec_dyn_wind_pres(Scheme_Dynamic_Wind_List * dwl,int dwl_len,Scheme_Cont * cont,MZ_MARK_STACK_TYPE copied_cms,int clear_cm_caches,Scheme_Object ** _sub_conts,int skip_dws)5321 static MZ_MARK_STACK_TYPE exec_dyn_wind_pres(Scheme_Dynamic_Wind_List *dwl,
5322 int dwl_len,
5323 Scheme_Cont *cont,
5324 MZ_MARK_STACK_TYPE copied_cms,
5325 int clear_cm_caches,
5326 Scheme_Object **_sub_conts,
5327 int skip_dws)
5328 {
5329 Scheme_Thread *p = scheme_current_thread;
5330 int old_cac = scheme_continuation_application_count;
5331 int need_clone = 0;
5332 Scheme_Dynamic_Wind *dw;
5333
5334 for (; dwl; dwl = dwl->next) {
5335 if (dwl->dw->pre) {
5336 p->next_meta = dwl->meta_depth + dwl->dw->next_meta;
5337 if (dwl->meta_depth > 0) {
5338 if (!skip_dws)
5339 scheme_apply_dw_in_meta(dwl->dw, 0, dwl->meta_depth, cont);
5340 } else {
5341 /* Restore the needed part of the mark stack for this
5342 dynamic-wind context. Clear cached info on restore
5343 if there's a prompt. */
5344 DW_PrePost_Proc pre = dwl->dw->pre;
5345 copy_in_mark_stack(p, cont->cont_mark_stack_copied,
5346 dwl->dw->envss.cont_mark_stack, copied_cms,
5347 cont->cont_mark_offset, _sub_conts,
5348 clear_cm_caches,
5349 dwl->dw->envss.cont_mark_pos);
5350 copied_cms = MZ_CONT_MARK_STACK;
5351
5352 if (!skip_dws)
5353 pre(dwl->dw->data);
5354
5355 if (!cont->composable) {
5356 if (scheme_continuation_application_count != old_cac) {
5357 old_cac = scheme_continuation_application_count;
5358 scheme_recheck_prompt_and_barrier(cont);
5359 }
5360 }
5361 }
5362 p = scheme_current_thread;
5363 }
5364
5365 if (p->dw != dwl->dw->prev) {
5366 /* something happened in the pre-thunk to change the
5367 continuation that we're building */
5368 need_clone = 1;
5369 }
5370
5371 if (need_clone) {
5372 dw = clone_dyn_wind(dwl->dw, NULL, -1, 1, p->dw, 0, 0);
5373 dw->next_meta = p->next_meta;
5374 } else
5375 dw = dwl->dw;
5376 p->dw = dw;
5377 }
5378 return copied_cms;
5379 }
5380
root_prompt_tag_misuse(const char * who)5381 static void root_prompt_tag_misuse(const char *who)
5382 {
5383 scheme_signal_error("%s: misuse of root prompt tag", who);
5384 }
5385
5386 static Scheme_Object *
call_cc(int argc,Scheme_Object * argv[])5387 call_cc (int argc, Scheme_Object *argv[])
5388 {
5389 scheme_check_proc_arity("call-with-current-continuation", 1,
5390 0, argc, argv);
5391 if (argc > 1) {
5392 if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[1]))
5393 && !((SCHEME_NP_CHAPERONEP(argv[1])
5394 && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(argv[1])))))
5395 scheme_wrong_contract("call-with-current-continuation", "continuation-prompt-tag?",
5396 1, argc, argv);
5397 }
5398
5399 /* Trampoline to internal_call_cc. This trampoline ensures that
5400 the runstack is flushed before we try to grab the continuation. */
5401 return _scheme_tail_apply(internal_call_cc_prim, argc, argv);
5402 }
5403
grab_continuation(Scheme_Thread * p,int for_prompt,int composable,Scheme_Object * prompt_tag,Scheme_Object * pt,Scheme_Cont * sub_cont,Scheme_Prompt * prompt,Scheme_Meta_Continuation * prompt_cont,Scheme_Prompt * effective_barrier_prompt,int cm_only,int argc,Scheme_Object ** argv)5404 static Scheme_Cont *grab_continuation(Scheme_Thread *p, int for_prompt, int composable,
5405 Scheme_Object *prompt_tag, Scheme_Object *pt,
5406 Scheme_Cont *sub_cont, Scheme_Prompt *prompt,
5407 Scheme_Meta_Continuation *prompt_cont,
5408 Scheme_Prompt *effective_barrier_prompt,
5409 int cm_only,
5410 int argc, Scheme_Object **argv)
5411 {
5412 Scheme_Cont *cont;
5413 Scheme_Cont_Jmp *buf_ptr;
5414
5415 cont = MALLOC_ONE_TAGGED(Scheme_Cont);
5416 cont->so.type = scheme_cont_type;
5417
5418 if (!for_prompt && !composable && !cm_only) {
5419 /* Set cont_key mark before capturing marks: */
5420 scheme_set_cont_mark(cont_key, (Scheme_Object *)cont);
5421 }
5422
5423 if (composable)
5424 cont->composable = 1;
5425
5426 buf_ptr = MALLOC_ONE_RT(Scheme_Cont_Jmp);
5427 SET_REQUIRED_TAG(buf_ptr->type = scheme_rt_cont_jmp);
5428 cont->buf_ptr = buf_ptr;
5429
5430 if (!cm_only) {
5431 scheme_init_jmpup_buf(&cont->buf_ptr->buf);
5432 cont->prompt_tag = prompt_tag;
5433 if (for_prompt)
5434 cont->dw = NULL;
5435 else if (prompt) {
5436 Scheme_Dynamic_Wind *dw;
5437 if (p->dw) {
5438 dw = clone_dyn_wind(p->dw, pt, -1, -1, NULL, 0, composable);
5439 cont->dw = dw;
5440 cont->next_meta = p->next_meta;
5441 } else
5442 cont->dw = NULL;
5443 } else {
5444 cont->dw = p->dw;
5445 cont->next_meta = p->next_meta;
5446 }
5447 }
5448 if (!for_prompt)
5449 ASSERT_SUSPEND_BREAK_ZERO();
5450 copy_cjs(&cont->cjs, &p->cjs);
5451 cont->save_overflow = p->overflow;
5452 scheme_save_env_stack_w_thread(cont->ss, p);
5453 cont->runstack_size = p->runstack_size;
5454 cont->runstack_start = MZ_RUNSTACK_START;
5455 cont->runstack_saved = p->runstack_saved;
5456 cont->meta_tail_pos = (prompt ? prompt->boundary_mark_pos + 2 : 0);
5457 cont->init_config = p->init_config;
5458 cont->init_break_cell = p->init_break_cell;
5459 if (for_prompt || cm_only) {
5460 cont->meta_continuation = NULL;
5461 } else if (prompt) {
5462 Scheme_Meta_Continuation *mc;
5463 mc = clone_meta_cont(p->meta_continuation, pt, -1, prompt_cont, prompt, NULL, composable);
5464 cont->meta_continuation = mc;
5465 if (!prompt_cont) {
5466 /* Remember the prompt id, so we can maybe take a shortcut on
5467 invocation. (The shortcut only works within a meta-continuation.) */
5468 init_prompt_id(prompt);
5469 cont->prompt_id = prompt->id;
5470 }
5471 cont->has_prompt_dw = 1;
5472 } else
5473 cont->meta_continuation = p->meta_continuation;
5474
5475 if (!cm_only) {
5476 /* A weak link is good enough for detecting continuation sharing, because
5477 if the meta continuation goes away, then we're certainly not capturing
5478 the same continuation as before. */
5479 Scheme_Object *meta_continuation_src;
5480 meta_continuation_src = scheme_make_weak_box((Scheme_Object *)p->meta_continuation);
5481 cont->meta_continuation_src = meta_continuation_src;
5482 }
5483
5484 if (effective_barrier_prompt) {
5485 cont->barrier_prompt = effective_barrier_prompt;
5486 scheme_prompt_capture_count++;
5487 }
5488
5489 if (p->meta_prompt && prompt_cont) /* prompt_cont => meta-prompt is shallower than prompt */
5490 prompt = p->meta_prompt;
5491
5492 if (!cm_only) {
5493 Scheme_Overflow *overflow;
5494 /* Mark overflows as captured: */
5495 for (overflow = p->overflow; overflow; overflow = overflow->prev) {
5496 overflow->jmp->captured = 1;
5497 }
5498 /* If prompt, then clone overflow records up to the prompt. */
5499 if (prompt) {
5500 overflow = clone_overflows(p->overflow, prompt->boundary_overflow_id, NULL);
5501 cont->save_overflow = overflow;
5502 }
5503 scheme_cont_capture_count++;
5504 }
5505
5506 if ((!effective_barrier_prompt || !effective_barrier_prompt->is_barrier) && !cm_only) {
5507 /* This continuation can be used by other threads,
5508 so we need to track ownership of the runstack */
5509 if (!p->runstack_owner) {
5510 Scheme_Thread **owner;
5511 owner = MALLOC_N(Scheme_Thread *, 1);
5512 p->runstack_owner = owner;
5513 *owner = p;
5514 }
5515 if (cont->ss.cont_mark_stack && !p->cont_mark_stack_owner) {
5516 Scheme_Thread **owner;
5517 owner = MALLOC_N(Scheme_Thread *, 1);
5518 p->cont_mark_stack_owner = owner;
5519 *owner = p;
5520 }
5521 }
5522
5523 #ifdef MZ_USE_JIT
5524 /* This information can be expensive to compute, no one uses it
5525 currently, and it's approximate anyway. So skip it. */
5526 if (0) {
5527 Scheme_Object *tr;
5528 tr = scheme_native_stack_trace();
5529 cont->native_trace = tr;
5530 }
5531 #endif
5532
5533 if (!cm_only) {
5534 Scheme_Saved_Stack *saved;
5535 saved = copy_out_runstack(p, MZ_RUNSTACK, MZ_RUNSTACK_START, sub_cont,
5536 (for_prompt ? p->meta_prompt : prompt));
5537 if (argv == MZ_RUNSTACK) {
5538 /* The copy of RUNSTACK that we just saved captures the arguments
5539 to `call/cc`, but we don't want to retain those. */
5540 intptr_t i;
5541 for (i = 0; i < argc; i++) {
5542 saved->runstack_start[i] = scheme_false;
5543 }
5544 }
5545 cont->runstack_copied = saved;
5546 if (!for_prompt && prompt) {
5547 /* Prune cont->runstack_saved to drop unneeded saves.
5548 (Note that this is different than runstack_copied;
5549 runstack_saved keeps the shared runstack buffers,
5550 not the content.) */
5551 if (scheme_prompt_runstack_boundary_start(prompt) == MZ_RUNSTACK_START)
5552 saved = NULL;
5553 else
5554 saved = clone_runstack_saved(cont->runstack_saved,
5555 scheme_prompt_runstack_boundary_start(prompt),
5556 NULL);
5557 cont->runstack_saved = saved;
5558 }
5559 }
5560
5561 {
5562 Scheme_Prompt *effective_prompt;
5563 Scheme_Cont_Mark *msaved;
5564 intptr_t offset;
5565 effective_prompt = (for_prompt ? p->meta_prompt : prompt);
5566 msaved = copy_out_mark_stack(p, cont->ss.cont_mark_stack, sub_cont, &offset,
5567 effective_prompt,
5568 /* If there's a prompt, then clear caches in the mark stack,
5569 since any cached values are wrong for the delimited
5570 continuation. Otherwise, leave the cache in place
5571 for operations directly on the continuation; the caches
5572 will be cleared on restore if the continuation is appended
5573 to another on invocation. */
5574 !!prompt);
5575 cont->cont_mark_stack_copied = msaved;
5576 cont->cont_mark_offset = offset;
5577 if (effective_prompt)
5578 cont->cont_mark_total = cont->ss.cont_mark_stack - effective_prompt->mark_boundary;
5579 else
5580 cont->cont_mark_total = cont->ss.cont_mark_stack;
5581 offset = find_shareable_marks();
5582 cont->cont_mark_nonshare = cont->ss.cont_mark_stack - offset;
5583 /* Need to remember the pos key for the bottom,
5584 at least for composable continuations, so
5585 we can splice the captured continuation marks
5586 with a meta continuation's marks. */
5587 cont->cont_mark_pos_bottom = (effective_prompt
5588 ? effective_prompt->boundary_mark_pos
5589 : 1);
5590 }
5591
5592 if (!cm_only) {
5593 cont->runstack_owner = p->runstack_owner;
5594 cont->cont_mark_stack_owner = p->cont_mark_stack_owner;
5595
5596 cont->stack_start = p->stack_start;
5597
5598 cont->savebuf = p->error_buf;
5599
5600 if (prompt)
5601 cont->prompt_buf = prompt->prompt_buf;
5602 }
5603
5604 return cont;
5605 }
5606
restore_continuation(Scheme_Cont * cont,Scheme_Thread * p,int for_prompt,Scheme_Object * result,Scheme_Overflow * resume,int empty_to_next_mc,Scheme_Object * prompt_tag,Scheme_Dynamic_Wind * common_dw,int common_next_meta,Scheme_Prompt * shortcut_prompt,int clear_cm_caches,int do_reset_cjs,Scheme_Cont * cm_cont,Scheme_Object * extra_marks)5607 static void restore_continuation(Scheme_Cont *cont, Scheme_Thread *p, int for_prompt,
5608 Scheme_Object *result,
5609 Scheme_Overflow *resume, int empty_to_next_mc,
5610 Scheme_Object *prompt_tag,
5611 Scheme_Dynamic_Wind *common_dw, int common_next_meta,
5612 Scheme_Prompt *shortcut_prompt,
5613 int clear_cm_caches, int do_reset_cjs,
5614 Scheme_Cont *cm_cont, Scheme_Object *extra_marks)
5615 {
5616 MZ_MARK_STACK_TYPE copied_cms = 0;
5617 Scheme_Object **mv, *sub_conts = NULL;
5618 Scheme_Cont *sub_cont;
5619 int mc;
5620
5621 if (SAME_OBJ(result, SCHEME_MULTIPLE_VALUES)) {
5622 /* Get values out before GC */
5623 mv = p->ku.multiple.array;
5624 mc = p->ku.multiple.count;
5625 if (SAME_OBJ(mv, p->values_buffer))
5626 p->values_buffer = NULL;
5627 p->ku.multiple.array = NULL;
5628 } else {
5629 mv = NULL;
5630 mc = 0;
5631 }
5632
5633 p->error_buf = cont->savebuf;
5634
5635 p->init_config = cont->init_config;
5636 p->init_break_cell = cont->init_break_cell;
5637
5638 if (do_reset_cjs)
5639 copy_cjs(&p->cjs, &cont->cjs);
5640 if (shortcut_prompt) {
5641 Scheme_Overflow *overflow;
5642 overflow = clone_overflows(cont->save_overflow, NULL, p->overflow);
5643 p->overflow = overflow;
5644 } else {
5645 p->overflow = cont->save_overflow;
5646 }
5647 if (for_prompt) {
5648 if (p->meta_prompt)
5649 cont->need_meta_prompt = 1;
5650 } else {
5651 Scheme_Meta_Continuation *mc, *resume_mc;
5652 if (resume) {
5653 resume_mc = MALLOC_ONE_RT(Scheme_Meta_Continuation);
5654 #ifdef MZTAG_REQUIRED
5655 resume_mc->type = scheme_rt_meta_cont;
5656 #endif
5657 resume_mc->overflow = resume;
5658
5659 resume_mc->prompt_tag = prompt_tag;
5660 resume_mc->pseudo = cont->composable;
5661 resume_mc->empty_to_next = empty_to_next_mc;
5662 resume_mc->meta_tail_pos = cont->meta_tail_pos;
5663
5664 if (!cm_cont) {
5665 /* resume must correspond to the implicit prompt at
5666 the thread's beginning. */
5667 } else {
5668 resume_mc->cont_mark_stack = cm_cont->ss.cont_mark_stack;
5669 resume_mc->cont_mark_pos = cm_cont->ss.cont_mark_pos;
5670 resume_mc->cont_mark_total = cm_cont->cont_mark_total;
5671 resume_mc->cont_mark_offset = cm_cont->cont_mark_offset;
5672 resume_mc->cont_mark_pos_bottom = cm_cont->cont_mark_pos_bottom;
5673 resume_mc->cont_mark_stack_copied = cm_cont->cont_mark_stack_copied;
5674
5675 resume_mc->cont = cm_cont;
5676
5677 resume_mc->cm_caches = 1; /* conservative assumption */
5678
5679 resume_mc->next = p->meta_continuation;
5680 if (p->meta_continuation)
5681 resume_mc->depth = p->meta_continuation->depth + 1;
5682 }
5683 } else
5684 resume_mc = NULL;
5685 if (resume_mc) {
5686 if (cont->composable) {
5687 /* Prune resume_mc continuation marks that have replacements
5688 in the deepest frame of cont, and add extra_marks */
5689 prune_cont_marks(resume_mc, cont, extra_marks);
5690 p->cont_mark_pos_bottom = cont->cont_mark_pos_bottom;
5691 }
5692
5693 mc = clone_meta_cont(cont->meta_continuation, NULL, -1, NULL, NULL, resume_mc, 0);
5694 } else if (shortcut_prompt) {
5695 mc = clone_meta_cont(cont->meta_continuation, NULL, -1, NULL, NULL, p->meta_continuation, 0);
5696 } else
5697 mc = cont->meta_continuation;
5698 p->meta_continuation = mc;
5699 }
5700
5701 if (shortcut_prompt) {
5702 /* In shortcut mode, we need to preserve saved runstacks
5703 that were pruned when capturing the continuation. */
5704 Scheme_Saved_Stack *rs;
5705 if (scheme_prompt_runstack_boundary_start(shortcut_prompt) == MZ_RUNSTACK_START)
5706 rs = p->runstack_saved;
5707 else {
5708 rs = p->runstack_saved;
5709 while (rs && (rs->runstack_start != scheme_prompt_runstack_boundary_start(shortcut_prompt))) {
5710 rs = rs->prev;
5711 }
5712 if (rs)
5713 rs = rs->prev;
5714 }
5715 if (rs)
5716 rs = clone_runstack_saved(cont->runstack_saved, NULL, rs);
5717 else
5718 rs = cont->runstack_saved;
5719 p->runstack_saved = rs;
5720 } else
5721 p->runstack_saved = cont->runstack_saved;
5722
5723 MZ_RUNSTACK_START = cont->runstack_start;
5724 p->runstack_size = cont->runstack_size;
5725
5726 scheme_restore_env_stack_w_thread(cont->ss, p);
5727
5728 if (p->runstack_owner
5729 && (*p->runstack_owner == p)) {
5730 *p->runstack_owner = NULL;
5731 }
5732
5733 if (resume)
5734 p->meta_prompt = NULL; /* in case there's a GC before we can set it */
5735
5736 p->runstack_owner = cont->runstack_owner;
5737 if (p->runstack_owner && (*p->runstack_owner != p)) {
5738 Scheme_Thread *op;
5739 op = *p->runstack_owner;
5740 if (op) {
5741 Scheme_Saved_Stack *saved;
5742 saved = copy_out_runstack(op, op->runstack, op->runstack_start, NULL, NULL);
5743 op->runstack_swapped = saved;
5744 }
5745 *p->runstack_owner = p;
5746 }
5747
5748 /* Copy stack back in: p->runstack and p->runstack_saved arrays
5749 are already restored, so the shape is certainly the same as
5750 when cont->runstack_copied was made. If we have a derived
5751 continuation, then we're sharing its base runstack. */
5752 copy_in_runstack(p, cont->runstack_copied, 0);
5753 {
5754 intptr_t done = cont->runstack_copied->runstack_size, size;
5755 sub_cont = cont;
5756 while (sub_cont) {
5757 if (sub_cont->buf_ptr->buf.cont
5758 && (sub_cont->runstack_start == sub_cont->buf_ptr->buf.cont->runstack_start)) {
5759 intptr_t delta;
5760 /* Copy shared part in: */
5761 sub_cont = sub_cont->buf_ptr->buf.cont;
5762 size = sub_cont->runstack_copied->runstack_size;
5763 /* Skip potential call/cc argument(s), which we don't want
5764 from the outer continuation. */
5765 if (size > MAX_CALL_CC_ARG_COUNT)
5766 delta = MAX_CALL_CC_ARG_COUNT;
5767 else
5768 delta = size;
5769 if (size > delta) {
5770 memcpy(MZ_RUNSTACK XFORM_OK_PLUS done,
5771 sub_cont->runstack_copied->runstack_start + delta,
5772 (size - delta) * sizeof(Scheme_Object *));
5773 done += (size - delta);
5774 }
5775 } else
5776 break;
5777 }
5778 }
5779
5780 if (p->cont_mark_stack_owner
5781 && (*p->cont_mark_stack_owner == p))
5782 *p->cont_mark_stack_owner = NULL;
5783
5784 p->cont_mark_stack_owner = cont->cont_mark_stack_owner;
5785 if (p->cont_mark_stack_owner
5786 && (*p->cont_mark_stack_owner != p)) {
5787 Scheme_Thread *op;
5788 op = *p->cont_mark_stack_owner;
5789 if (op) {
5790 Scheme_Cont_Mark *msaved;
5791 msaved = copy_out_mark_stack(op, op->cont_mark_stack, NULL, NULL, NULL, 0);
5792 op->cont_mark_stack_swapped = msaved;
5793 }
5794 *p->cont_mark_stack_owner = p;
5795 /* In case there's a GC before we copy in marks: */
5796 MZ_CONT_MARK_STACK = 0;
5797 }
5798
5799 /* If there's a resume, then set up a meta prompt.
5800 We also need a meta-prompt if we're returning from a composed
5801 continuation to a continuation captured under a meta-prompt,
5802 or truncated somewhere along the way. */
5803 if (resume || (for_prompt && cont->need_meta_prompt)) {
5804 Scheme_Prompt *meta_prompt;
5805
5806 meta_prompt = MALLOC_ONE_TAGGED(Scheme_Prompt);
5807 meta_prompt->so.type = scheme_prompt_type;
5808 meta_prompt->stack_boundary = cont->prompt_stack_start;
5809 meta_prompt->boundary_overflow_id = NULL;
5810 {
5811 Scheme_Cont *tc;
5812 for (tc = cont; tc->buf_ptr->buf.cont; tc = tc->buf_ptr->buf.cont) {
5813 }
5814 meta_prompt->mark_boundary = tc->cont_mark_offset;
5815 }
5816 meta_prompt->prompt_buf = cont->prompt_buf;
5817 {
5818 /* Reverse-engineer where the saved runstack ends: */
5819 Scheme_Cont *rs_cont = cont;
5820 Scheme_Saved_Stack *saved, *actual;
5821 int delta = 0;
5822 while (rs_cont->buf_ptr->buf.cont
5823 && (rs_cont->buf_ptr->buf.cont->runstack_start == cont->runstack_start)) {
5824 delta += rs_cont->runstack_copied->runstack_size;
5825 rs_cont = rs_cont->buf_ptr->buf.cont;
5826 if (rs_cont->runstack_copied->runstack_size > MAX_CALL_CC_ARG_COUNT) {
5827 delta -= MAX_CALL_CC_ARG_COUNT; /* overlap for not-saved call/cc argument */
5828 }
5829 }
5830 actual = NULL;
5831 for (saved = rs_cont->runstack_copied; saved->prev; saved = saved->prev) {
5832 if (!actual)
5833 actual = p->runstack_saved;
5834 else
5835 actual = actual->prev;
5836 }
5837 if (actual) {
5838 meta_prompt->u.runstack_boundary_start = actual->runstack_start;
5839 meta_prompt->runstack_boundary_offset = actual->runstack_offset + saved->runstack_size;
5840 } else {
5841 meta_prompt->u.runstack_boundary_start = MZ_RUNSTACK_START;
5842 meta_prompt->runstack_boundary_offset = (MZ_RUNSTACK - MZ_RUNSTACK_START) + saved->runstack_size + delta;
5843 MZ_ASSERT(meta_prompt->runstack_boundary_offset <= scheme_current_thread->runstack_size);
5844 }
5845 }
5846
5847 meta_prompt->boundary_mark_pos = cont->cont_mark_pos_bottom; /* for mark splicing */
5848
5849 p->meta_prompt = meta_prompt;
5850 }
5851
5852 /* For copying cont marks back in, we need a list of sub_conts,
5853 deepest to shallowest: */
5854 copied_cms = cont->cont_mark_offset;
5855 for (sub_cont = cont->buf_ptr->buf.cont; sub_cont; sub_cont = sub_cont->buf_ptr->buf.cont) {
5856 copied_cms = sub_cont->cont_mark_offset;
5857 sub_conts = scheme_make_raw_pair((Scheme_Object *)sub_cont, sub_conts);
5858 }
5859
5860 if (!shortcut_prompt) {
5861 Scheme_Cont *tc;
5862 for (tc = cont; tc->buf_ptr->buf.cont; tc = tc->buf_ptr->buf.cont) {
5863 }
5864 p->cont_mark_stack_bottom = tc->cont_mark_offset;
5865 p->cont_mark_pos_bottom = tc->cont_mark_pos_bottom;
5866 }
5867
5868 if (for_prompt) {
5869 /* leave p->dw alone */
5870 } else {
5871 /* For dynamic-winds after the "common" intersection
5872 (see eval.c), execute the pre thunks. Make a list
5873 of these first because they have to be done in the
5874 inverse order of `prev' linkage. */
5875 Scheme_Dynamic_Wind *dw, *all_dw;
5876 Scheme_Dynamic_Wind_List *dwl = NULL;
5877 int common_depth, dwl_len = 0;
5878
5879 /* The thread's dw is set to the common dw. */
5880
5881 if (resume) {
5882 /* Figure out which dynamic winds use meta-continuations
5883 after an added one. */
5884 if (cont->composable) {
5885 /* All of them! */
5886 p->next_meta++;
5887 } else {
5888 /* D-Ws after the tag are now one further way:
5889 after the newly inserted meta-continuation for this tag. */
5890 p->dw = common_dw;
5891 p->next_meta = common_next_meta;
5892 if (p->dw) { /* can be empty if there's only the implicit prompt */
5893 /* also, there may be no dw with prompt_tag if there's only the implicit prompt */
5894 all_dw = clone_dyn_wind(p->dw, cont->prompt_tag, -1, -1, NULL, 1, 0);
5895 for (dw = all_dw; dw && !SAME_OBJ(dw->prompt_tag, cont->prompt_tag); dw = dw->prev) {
5896 p->dw = p->dw->prev;
5897 }
5898 if (dw)
5899 dw->next_meta += 1;
5900 p->dw = all_dw;
5901 }
5902 }
5903 } else {
5904 p->dw = common_dw;
5905 p->next_meta = common_next_meta;
5906 }
5907
5908 if (cont->dw) {
5909 int meta_depth;
5910
5911 /* The allow_dw chain that we build up here is actually
5912 premature, in that the tail to splice onto may change
5913 in pre-thunks. It doesn't usually happen, and we can
5914 detect that case in exec_dyn_wind_pres() in re-clone. */
5915 common_depth = (p->dw ? p->dw->depth : -1);
5916 all_dw = clone_dyn_wind(cont->dw, NULL, cont->common_dw_depth, -1, p->dw, 0, 0);
5917
5918 if ((common_depth != -1) && (common_depth != all_dw->depth)) {
5919 /* Move p->next_meta to the last added dw's next_meta. */
5920 for (dw = all_dw; dw->prev->depth != common_depth; dw = dw->prev) {
5921 }
5922 dw->next_meta = p->next_meta;
5923 }
5924
5925 meta_depth = cont->next_meta;
5926 for (dw = all_dw; dw && (dw->depth != common_depth); dw = dw->prev) {
5927 Scheme_Dynamic_Wind_List *cell;
5928
5929 cell = MALLOC_ONE_RT(Scheme_Dynamic_Wind_List);
5930 #ifdef MZTAG_REQUIRED
5931 cell->type = scheme_rt_dyn_wind_cell;
5932 #endif
5933 cell->dw = dw;
5934 cell->meta_depth = meta_depth;
5935 cell->next = dwl;
5936 dwl = cell;
5937 dwl_len++;
5938
5939 meta_depth += dw->next_meta;
5940 }
5941 copied_cms = exec_dyn_wind_pres(dwl, dwl_len, cont, copied_cms, clear_cm_caches, &sub_conts,
5942 cont->skip_dws);
5943 p = scheme_current_thread;
5944 p->next_meta = cont->next_meta;
5945 }
5946 }
5947
5948 if (!for_prompt)
5949 p->suspend_break = 0;
5950
5951 /* Finish copying cont mark stack back in. */
5952
5953 copy_in_mark_stack(p, cont->cont_mark_stack_copied,
5954 cont->ss.cont_mark_stack, copied_cms,
5955 cont->cont_mark_offset, &sub_conts,
5956 clear_cm_caches,
5957 cont->ss.cont_mark_pos);
5958
5959 if (SAME_OBJ(result, SCHEME_MULTIPLE_VALUES)) {
5960 p->ku.multiple.array = mv;
5961 p->ku.multiple.count = mc;
5962 }
5963 }
5964
5965 static Scheme_Object *
internal_call_cc(int argc,Scheme_Object * argv[])5966 internal_call_cc (int argc, Scheme_Object *argv[])
5967 {
5968 Scheme_Object *ret, * volatile pt, * prompt_tag;
5969 Scheme_Cont * volatile cont;
5970 Scheme_Cont *sub_cont;
5971 Scheme_Meta_Continuation *prompt_cont, *barrier_cont;
5972 MZ_MARK_POS_TYPE prompt_pos, barrier_pos;
5973 Scheme_Thread *p = scheme_current_thread;
5974 Scheme_Prompt *prompt, *barrier_prompt, *effective_barrier_prompt;
5975 Scheme_Object *ec;
5976 GC_CAN_IGNORE void *stack_start;
5977 int composable;
5978
5979 if (argc > 1)
5980 prompt_tag = argv[1];
5981 else
5982 prompt_tag = scheme_default_prompt_tag;
5983
5984 if (SCHEME_NP_CHAPERONEP(prompt_tag))
5985 pt = SCHEME_CHAPERONE_VAL(prompt_tag);
5986 else
5987 pt = prompt_tag;
5988
5989 composable = (argc > 2);
5990
5991 if (SAME_OBJ(pt, scheme_root_prompt_tag)) {
5992 root_prompt_tag_misuse(composable
5993 ? "call-with-composable-continuation"
5994 : "call-with-current-continuation");
5995 return NULL;
5996 }
5997
5998 prompt = scheme_get_prompt(SCHEME_PTR_VAL(pt), &prompt_cont, &prompt_pos);
5999 if (!prompt && !SAME_OBJ(scheme_default_prompt_tag, pt)) {
6000 scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
6001 "%s: continuation includes no prompt with the given tag\n"
6002 " tag: %V",
6003 (composable
6004 ? "call-with-composable-continuation"
6005 : "call-with-current-continuation"),
6006 prompt_tag);
6007 return NULL;
6008 }
6009
6010 /* This prompt is likely to be on the C stack when we capture it for
6011 the continuation, but we only want to retain the prompt's
6012 runstack. Convert it to one that has the same ID but holds the
6013 runstack weakly. */
6014 if (prompt)
6015 prompt = make_weak_prompt(prompt);
6016
6017 barrier_prompt = scheme_get_barrier_prompt(&barrier_cont, &barrier_pos);
6018
6019 if (composable && SCHEME_FALSEP(argv[2])) {
6020 if (!prompt && !barrier_prompt->is_barrier) {
6021 /* Pseduo-prompt ok. */
6022 } else {
6023 if (!prompt
6024 || scheme_is_cm_deeper(prompt_cont, prompt_pos, barrier_cont, barrier_pos)) {
6025 scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
6026 "call-with-composable-continuation: cannot capture past continuation barrier");
6027 }
6028 }
6029 }
6030
6031 effective_barrier_prompt = barrier_prompt;
6032 if (effective_barrier_prompt && prompt) {
6033 if (scheme_is_cm_deeper(barrier_cont, barrier_pos,
6034 prompt_cont, prompt_pos))
6035 effective_barrier_prompt = NULL;
6036 }
6037
6038 if (composable)
6039 sub_cont = NULL;
6040 else
6041 sub_cont = (Scheme_Cont *)scheme_extract_one_cc_mark(NULL, cont_key);
6042 if (sub_cont
6043 && (sub_cont->save_overflow == p->overflow)
6044 && (sub_cont->prompt_tag == prompt_tag)
6045 && (sub_cont->barrier_prompt == effective_barrier_prompt)
6046 && (((Scheme_Escaping_Cont *)sub_cont->escape_cont)->myerr == p->error_buf)) {
6047 /* Whether sub_cont turns out to be the same continuation, we can use
6048 its escape continuation, because jumping to the escape continuation
6049 triggers the same C-level clean-up actions, same `dynamic-wind's, and
6050 crosses the same continuation barriers. */
6051 ec = sub_cont->escape_cont;
6052 } else
6053 ec = NULL;
6054 if (sub_cont && ((sub_cont->save_overflow != p->overflow)
6055 || (sub_cont->prompt_tag != prompt_tag)
6056 || (sub_cont->barrier_prompt != effective_barrier_prompt)
6057 || ((Scheme_Meta_Continuation *)SCHEME_WEAK_BOX_VAL(sub_cont->meta_continuation_src)
6058 != p->meta_continuation))) {
6059 sub_cont = NULL;
6060 }
6061 if (sub_cont && (sub_cont->ss.cont_mark_pos == MZ_CONT_MARK_POS)) {
6062 Scheme_Object *argv2[1];
6063 #ifdef MZ_USE_JIT
6064 /* See note above on how the stack trace is expensive to compute
6065 and not all that useful. */
6066 if (0)
6067 ret = scheme_native_stack_trace();
6068 else
6069 ret = NULL;
6070 #endif
6071 /* Old cont is the same as this one, except that it may
6072 have different marks (not counting cont_key). */
6073 if (!sub_cont->cont_mark_nonshare
6074 && (find_shareable_marks() == MZ_CONT_MARK_STACK)
6075 #ifdef MZ_USE_JIT
6076 && (SAME_OBJ(ret, sub_cont->native_trace)
6077 /* Maybe a single-function loop, where we re-allocated the
6078 last pair in the trace, but it's the same name: */
6079 || (ret
6080 && sub_cont->native_trace
6081 && SCHEME_PAIRP(ret)
6082 && SCHEME_PAIRP(sub_cont->native_trace)
6083 && SAME_OBJ(SCHEME_CAR(ret), SCHEME_CAR(sub_cont->native_trace))
6084 && SAME_OBJ(SCHEME_CDR(ret), SCHEME_CDR(sub_cont->native_trace))))
6085 #endif
6086 ) {
6087 /* Just use this one. */
6088 cont = sub_cont;
6089 } else {
6090 /* Only continuation marks can be different. Mostly just re-use sub_cont.
6091 The mark stack won't be restored, but it may be
6092 used by `continuation-marks'. */
6093
6094 cont = grab_continuation(p, 0, 0, prompt_tag, pt, sub_cont,
6095 prompt, prompt_cont, effective_barrier_prompt, 1,
6096 argc, argv);
6097 #ifdef MZ_USE_JIT
6098 cont->native_trace = ret;
6099 #endif
6100
6101 cont->buf_ptr->buf.cont = sub_cont;
6102 cont->escape_cont = sub_cont->escape_cont;
6103 }
6104
6105 argv2[0] = (Scheme_Object *)cont;
6106 return _scheme_tail_apply(argv[0], 1, argv2);
6107 }
6108
6109 cont = grab_continuation(p, 0, composable, prompt_tag, pt, sub_cont,
6110 prompt, prompt_cont, effective_barrier_prompt, 0,
6111 argc, argv);
6112
6113 scheme_zero_unneeded_rands(p);
6114
6115 scheme_flatten_config(scheme_current_config());
6116
6117 {
6118 void *overflow_id;
6119
6120 overflow_id = (p->overflow
6121 ? (p->overflow->id
6122 ? p->overflow->id
6123 : p->overflow)
6124 : NULL);
6125
6126 if (prompt
6127 && !prompt_cont
6128 && (prompt->boundary_overflow_id == overflow_id)) {
6129 /* Must be inside barrier_prompt, or it wouldn't be allowed.
6130 Must be inside meta_prompt, or prompt_cont would be non-NULL.
6131 Must be inside overflow, or the ids wouldn't match. */
6132 stack_start = prompt->stack_boundary;
6133 } else {
6134 Scheme_Prompt *meta_prompt, *stack_barrier_prompt;
6135
6136 stack_barrier_prompt = barrier_prompt;
6137
6138 if (!stack_barrier_prompt->is_barrier)
6139 stack_barrier_prompt = NULL;
6140 else if (stack_barrier_prompt->boundary_overflow_id != overflow_id)
6141 stack_barrier_prompt = NULL;
6142 meta_prompt = p->meta_prompt;
6143 if (meta_prompt)
6144 if (meta_prompt->boundary_overflow_id != overflow_id)
6145 meta_prompt = NULL;
6146
6147 if (stack_barrier_prompt && meta_prompt) {
6148 stack_barrier_prompt = NULL;
6149 }
6150
6151 if (stack_barrier_prompt)
6152 stack_start = stack_barrier_prompt->stack_boundary;
6153 else if (meta_prompt)
6154 stack_start = meta_prompt->stack_boundary;
6155 else
6156 stack_start = p->stack_start;
6157 }
6158 }
6159
6160 /* Use cont->stack_start when calling `cont' directly
6161 from the same meta-continuation. Use cont->prompt_stack_start
6162 when calling `cont' composably (i.e., when supplying a resume). */
6163 cont->prompt_stack_start = stack_start;
6164
6165 cont->escape_cont = ec;
6166
6167 /* Zero out any local variable that shouldn't be saved by the
6168 continuation. The meta-continuation for the prompt is an
6169 especially important one to zero out (otherwise we build up
6170 chains). */
6171 prompt_cont = NULL;
6172 barrier_cont = NULL;
6173
6174 if (scheme_setjmpup_relative(&cont->buf_ptr->buf, cont->buf_ptr, stack_start, sub_cont)) {
6175 /* We arrive here when the continuation is applied */
6176 Scheme_Object *result, *extra_marks;
6177 Scheme_Overflow *resume;
6178 Scheme_Cont *use_next_cont;
6179 Scheme_Dynamic_Wind *common_dw;
6180 Scheme_Prompt *shortcut_prompt;
6181 int common_next_meta, empty_to_next_mc;
6182
6183 p = scheme_current_thread; /* maybe different than before */
6184
6185 result = cont->value;
6186 cont->value = NULL;
6187
6188 resume = cont->resume_to;
6189 cont->resume_to = NULL;
6190
6191 use_next_cont = cont->use_next_cont;
6192 cont->use_next_cont = NULL;
6193
6194 extra_marks = cont->extra_marks;
6195 cont->extra_marks = NULL;
6196
6197 common_dw = cont->common_dw;
6198 cont->common_dw = NULL;
6199
6200 common_next_meta = cont->common_next_meta;
6201 cont->common_next_meta = 0;
6202
6203 shortcut_prompt = cont->shortcut_prompt;
6204 cont->shortcut_prompt = NULL;
6205
6206 empty_to_next_mc = cont->empty_to_next_mc;
6207 cont->empty_to_next_mc = 0;
6208
6209 restore_continuation(cont, p, 0, result, resume, empty_to_next_mc,
6210 pt,
6211 common_dw, common_next_meta, shortcut_prompt,
6212 !!resume, 1,
6213 use_next_cont, extra_marks);
6214
6215 /* We may have just re-activated breaking: */
6216 scheme_check_break_now();
6217
6218 if (!scheme_get_barrier_prompt(NULL, NULL)) {
6219 /* The continuation was applied in a thread where the barrier prompt
6220 was supposed to be the pseduo-prompt for a thread, but we've lost
6221 that prompt. The barrier prompt from capturing the continuation
6222 has the right info, but we need to claim that it's not a barrier
6223 from the perspective of changing continuations. */
6224 Scheme_Prompt *acting_barrier_prompt;
6225 if (!barrier_prompt->is_barrier)
6226 acting_barrier_prompt = barrier_prompt;
6227 else {
6228 acting_barrier_prompt = MALLOC_ONE_TAGGED(Scheme_Prompt);
6229 memcpy(acting_barrier_prompt, barrier_prompt, sizeof(Scheme_Prompt));
6230 acting_barrier_prompt->is_barrier = 0;
6231 }
6232 p->acting_barrier_prompt = acting_barrier_prompt;
6233 }
6234
6235 {
6236 Scheme_Meta_Continuation *mc;
6237 MZ_MARK_POS_TYPE pos;
6238 Scheme_Object *cc_guard;
6239
6240 prompt = scheme_get_prompt(SCHEME_PTR_VAL(pt), &mc, &pos);
6241 if (prompt && (prompt->has_chaperone || SCHEME_NP_CHAPERONEP(cont->prompt_tag))) {
6242 cc_guard = get_set_cont_mark_by_pos(prompt_cc_guard_key, p, mc, pos, NULL);
6243
6244 if (SCHEME_FALSEP(cc_guard))
6245 cc_guard = scheme_values_proc;
6246 if (SCHEME_NP_CHAPERONEP(cont->prompt_tag))
6247 cc_guard = chaperone_wrap_cc_guard(cont->prompt_tag, cc_guard);
6248
6249 get_set_cont_mark_by_pos(prompt_cc_guard_key, p, mc, pos, cc_guard);
6250 }
6251 }
6252
6253 if ((result != SCHEME_MULTIPLE_VALUES)
6254 && SAME_TYPE(SCHEME_TYPE(result), scheme_thunk_for_continue_type))
6255 return _scheme_tail_apply(SCHEME_PTR_VAL(result), 0, NULL);
6256 else
6257 return result;
6258 } else if (composable || cont->escape_cont) {
6259 Scheme_Object *argv2[1];
6260
6261 if (SCHEME_TRUEP(argv[2]))
6262 cont->skip_dws = 1;
6263
6264 argv2[0] = (Scheme_Object *)cont;
6265 ret = _scheme_tail_apply(argv[0], 1, argv2);
6266 return ret;
6267 } else {
6268 Scheme_Object *argv2[2];
6269
6270 argv2[0] = argv[0];
6271 argv2[1] = (Scheme_Object *)cont;
6272
6273 ret = _scheme_tail_apply(finish_call_cc_prim, 2, argv2);
6274 return ret;
6275 }
6276 }
6277
6278 static Scheme_Object *
finish_call_cc(int argc,Scheme_Object * argv[])6279 finish_call_cc (int argc, Scheme_Object *argv[])
6280 {
6281 return do_call_ec(1, argv, argv[1]);
6282 }
6283
call_in_continuation(int argc,Scheme_Object * argv[])6284 static Scheme_Object *call_in_continuation (int argc, Scheme_Object *argv[])
6285 {
6286 Scheme_Object *k = argv[0], *p, *a[1];
6287
6288 if (!SCHEME_CONTP(k) && !SCHEME_ECONTP(k))
6289 scheme_wrong_contract("call-in-continuation", "continuation?", 0, argc, argv);
6290
6291 scheme_check_proc_arity("call-in-continuation", 0, 1, argc, argv);
6292
6293 /* Instead of allocating, we chould thread a flag through to say
6294 that the value in `argv` should be applied instead of returned.
6295 But we're not likely to notice the cost of this allocation,
6296 anyway. */
6297 p = scheme_alloc_small_object();
6298 p->type = scheme_thunk_for_continue_type;
6299 SCHEME_PTR_VAL(p) = argv[1];
6300
6301 a[0] = p;
6302
6303 if (SCHEME_CONTP(k)) {
6304 /* We can use escape mode only if coontinuation marks didn't change. */
6305 int can_escape = 0;
6306 return scheme_jump_to_continuation(k, 1, a, MZ_RUNSTACK, can_escape);
6307 } else {
6308 scheme_escape_to_continuation(k, 1, a, NULL);
6309 return NULL;
6310 }
6311 }
6312
continuation_p(int argc,Scheme_Object * argv[])6313 static Scheme_Object *continuation_p (int argc, Scheme_Object *argv[])
6314 {
6315 return ((SCHEME_CONTP(argv[0]) || SCHEME_ECONTP(argv[0]))
6316 ? scheme_true
6317 : scheme_false);
6318 }
6319
scheme_takeover_stacks(Scheme_Thread * p)6320 void scheme_takeover_stacks(Scheme_Thread *p)
6321 /* When a continuation captured in on e thread is invoked in another,
6322 the two threads can start using the same runstack, and possibly
6323 also the same cont-mark stack. This function swaps out the
6324 current owner in favor of p */
6325
6326 {
6327 if (p->runstack_owner && ((*p->runstack_owner) != p)) {
6328 Scheme_Thread *op;
6329 Scheme_Saved_Stack *swapped;
6330 op = *p->runstack_owner;
6331 if (op) {
6332 swapped = copy_out_runstack(op, op->runstack, op->runstack_start, NULL, NULL);
6333 op->runstack_swapped = swapped;
6334 }
6335 *(p->runstack_owner) = p;
6336 copy_in_runstack(p, p->runstack_swapped, 1);
6337 p->runstack_swapped = NULL;
6338 }
6339
6340 if (p->cont_mark_stack_owner && ((*p->cont_mark_stack_owner) != p)) {
6341 Scheme_Thread *op;
6342 Scheme_Cont_Mark *swapped;
6343 op = *p->cont_mark_stack_owner;
6344 if (op) {
6345 swapped = copy_out_mark_stack(op, op->cont_mark_stack, NULL, NULL, NULL, 0);
6346 op->cont_mark_stack_swapped = swapped;
6347 }
6348 *(p->cont_mark_stack_owner) = p;
6349 copy_in_mark_stack(p, p->cont_mark_stack_swapped, MZ_CONT_MARK_STACK, 0, 0, NULL, 0, MZ_CONT_MARK_POS);
6350 p->cont_mark_stack_swapped = NULL;
6351 }
6352 }
6353
6354 static Scheme_Object *
call_with_continuation_barrier(int argc,Scheme_Object * argv[])6355 call_with_continuation_barrier (int argc, Scheme_Object *argv[])
6356 {
6357 scheme_check_proc_arity("call-with-continuation-barrier", 0, 0, argc, argv);
6358
6359 /* scheme_apply_multi() is a top-level evaluation function and will
6360 thus install a continuation barrier */
6361 return scheme_apply_multi(argv[0], 0, NULL);
6362 }
6363
scheme_get_barrier_prompt(Scheme_Meta_Continuation ** _meta_cont,MZ_MARK_POS_TYPE * _pos)6364 Scheme_Prompt *scheme_get_barrier_prompt(Scheme_Meta_Continuation **_meta_cont,
6365 MZ_MARK_POS_TYPE *_pos)
6366 {
6367 Scheme_Prompt *p;
6368
6369 p = (Scheme_Prompt *)scheme_extract_one_cc_mark_with_meta(NULL, barrier_prompt_key, NULL, _meta_cont, _pos);
6370 if (!p) {
6371 p = scheme_current_thread->acting_barrier_prompt;
6372 if (_meta_cont) {
6373 /* acting barrier prompt is deepest: */
6374 Scheme_Meta_Continuation *mc = scheme_current_thread->meta_continuation;
6375 while (mc && mc->next) {
6376 mc = mc->next;
6377 }
6378 *_meta_cont = mc;
6379 *_pos = -1;
6380 }
6381 }
6382
6383 return p;
6384 }
6385
scheme_get_prompt(Scheme_Object * prompt_tag,Scheme_Meta_Continuation ** _meta_cont,MZ_MARK_POS_TYPE * _pos)6386 Scheme_Prompt *scheme_get_prompt(Scheme_Object *prompt_tag,
6387 Scheme_Meta_Continuation **_meta_cont,
6388 MZ_MARK_POS_TYPE *_pos)
6389 {
6390 return (Scheme_Prompt *)scheme_extract_one_cc_mark_with_meta(NULL, prompt_tag, NULL, _meta_cont, _pos);
6391 }
6392
scheme_get_meta_continuation(Scheme_Object * key)6393 static Scheme_Meta_Continuation *scheme_get_meta_continuation(Scheme_Object *key)
6394 {
6395 Scheme_Meta_Continuation *mc;
6396 scheme_extract_one_cc_mark_with_meta(NULL, key, NULL, &mc, NULL);
6397 return mc;
6398 }
6399
6400
make_prompt_tag(int argc,Scheme_Object * argv[])6401 static Scheme_Object *make_prompt_tag (int argc, Scheme_Object *argv[])
6402 {
6403 Scheme_Object *o, *key;
6404
6405 if (argc && !SCHEME_SYMBOLP(argv[0]))
6406 scheme_wrong_contract("make-continuation-prompt-tag", "symbol?", 0, argc, argv);
6407
6408 key = scheme_make_pair(scheme_false, scheme_false);
6409
6410 o = scheme_alloc_object();
6411 o->type = scheme_prompt_tag_type;
6412 SCHEME_CAR(o) = key;
6413 SCHEME_CDR(o) = (argc ? argv[0] : NULL);
6414
6415 return o;
6416 }
6417
get_default_prompt_tag(int argc,Scheme_Object * argv[])6418 static Scheme_Object *get_default_prompt_tag (int argc, Scheme_Object *argv[])
6419 {
6420 return scheme_default_prompt_tag;
6421 }
6422
prompt_tag_p(int argc,Scheme_Object * argv[])6423 static Scheme_Object *prompt_tag_p (int argc, Scheme_Object *argv[])
6424 {
6425 return (SCHEME_CHAPERONE_PROMPT_TAGP(argv[0])
6426 ? scheme_true
6427 : scheme_false);
6428 }
6429
do_chaperone_prompt_tag(const char * name,int is_impersonator,int argc,Scheme_Object ** argv)6430 Scheme_Object *do_chaperone_prompt_tag (const char *name, int is_impersonator, int argc, Scheme_Object **argv)
6431 {
6432 Scheme_Chaperone *px;
6433 Scheme_Object *val = argv[0];
6434 Scheme_Object *redirects;
6435 Scheme_Object *props;
6436 int ppos;
6437
6438 if (SCHEME_CHAPERONEP(val))
6439 val = SCHEME_CHAPERONE_VAL(val);
6440
6441 if (!SCHEME_PROMPT_TAGP(val))
6442 scheme_wrong_contract(name, "prompt-tag?", 0, argc, argv);
6443
6444 if (!SCHEME_PROCP(argv[1]))
6445 scheme_wrong_contract(name, "procedure?", 1, argc, argv);
6446 if (!SCHEME_PROCP(argv[2]))
6447 scheme_wrong_contract(name, "procedure?", 2, argc, argv);
6448
6449 if ((argc > 3) && !SCHEME_CHAPERONEP(argv[3])) {
6450 if (!SCHEME_PROCP(argv[3]))
6451 scheme_wrong_contract(name, "(or/c procedure? impersonator-property?)", 3, argc, argv);
6452 redirects = argv[3];
6453 if ((argc > 4) && !SCHEME_CHAPERONEP(argv[4])) {
6454 if (!scheme_check_proc_arity(NULL, 1, 4, argc, argv))
6455 scheme_wrong_contract(name, "(or/c (procedure-arity-includes/c 1) impersonator-property?)", 4, argc, argv);
6456 redirects = scheme_make_pair(redirects, argv[4]);
6457 ppos = 5;
6458 } else
6459 ppos = 4;
6460 redirects = scheme_make_pair(argv[2], redirects);
6461 } else {
6462 ppos = 3;
6463 redirects = argv[2];
6464 }
6465
6466 redirects = scheme_make_pair(argv[1], redirects);
6467
6468 props = scheme_parse_chaperone_props(name, ppos, argc, argv);
6469
6470 px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
6471 px->iso.so.type = scheme_chaperone_type;
6472 px->val = val;
6473 px->prev = argv[0];
6474 px->props = props;
6475 px->redirects = redirects;
6476
6477 if (is_impersonator)
6478 SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;
6479
6480 return (Scheme_Object *)px;
6481 }
6482
chaperone_prompt_tag(int argc,Scheme_Object ** argv)6483 static Scheme_Object *chaperone_prompt_tag(int argc, Scheme_Object **argv)
6484 {
6485 return do_chaperone_prompt_tag("chaperone-prompt-tag", 0, argc, argv);
6486 }
6487
impersonate_prompt_tag(int argc,Scheme_Object ** argv)6488 static Scheme_Object *impersonate_prompt_tag(int argc, Scheme_Object **argv)
6489 {
6490 return do_chaperone_prompt_tag("impersonate-prompt-tag", 1, argc, argv);
6491 }
6492
scheme_get_thread_end_overflow(void)6493 Scheme_Overflow *scheme_get_thread_end_overflow(void)
6494 {
6495 Scheme_Overflow *overflow;
6496 overflow = MALLOC_ONE_RT(Scheme_Overflow);
6497 #ifdef MZTAG_REQUIRED
6498 overflow->type = scheme_rt_overflow;
6499 #endif
6500 overflow->eot = 1;
6501 return overflow;
6502 }
6503
6504
scheme_drop_prompt_meta_continuations(Scheme_Object * prompt_tag)6505 void scheme_drop_prompt_meta_continuations(Scheme_Object *prompt_tag)
6506 {
6507 Scheme_Meta_Continuation *mc;
6508
6509 mc = scheme_current_thread->meta_continuation;
6510 while (!SAME_OBJ(mc->prompt_tag, prompt_tag)) {
6511 if (mc->overflow) {
6512 scheme_signal_error("meta-continuation to drop is not just a placeholder?!");
6513 }
6514 mc = mc->next;
6515 }
6516
6517 scheme_current_thread->meta_continuation = mc;
6518 }
6519
6520 MZ_DO_NOT_INLINE(Scheme_Object *scheme_finish_apply_for_prompt(Scheme_Prompt *prompt, Scheme_Object *_prompt_tag,
6521 Scheme_Object *proc, int argc, Scheme_Object **argv));
6522
scheme_finish_apply_for_prompt(Scheme_Prompt * prompt,Scheme_Object * _prompt_tag,Scheme_Object * proc,int argc,Scheme_Object ** argv)6523 Scheme_Object *scheme_finish_apply_for_prompt(Scheme_Prompt *prompt, Scheme_Object *_prompt_tag,
6524 Scheme_Object *proc, int argc, Scheme_Object **argv)
6525 {
6526 /* Put space on the stack to record a longjmp target,
6527 in case a following continuation is restored for a
6528 different prompt.
6529 By putting this information on the stack, it will
6530 get captured if there's a further capture. */
6531 Scheme_Thread *p;
6532 Scheme_Object * volatile prompt_tag = _prompt_tag;
6533 mz_jmp_buf newbuf, * volatile savebuf;
6534 Scheme_Object *val;
6535 int cc_count = scheme_cont_capture_count;
6536
6537 prompt->prompt_buf = &newbuf;
6538 prompt = NULL; /* to avoid prompt chains */
6539
6540 p = scheme_current_thread;
6541
6542 savebuf = p->error_buf;
6543 p->error_buf = &newbuf;
6544
6545 /* Initial meta-continuation says to fall through. This
6546 one can get replaced when the current continuation
6547 is captured and then restored. */
6548 {
6549 Scheme_Meta_Continuation *resume_mc;
6550 if (available_prompt_mc) {
6551 resume_mc = available_prompt_mc;
6552 available_prompt_mc = NULL;
6553 } else
6554 resume_mc = MALLOC_ONE_RT(Scheme_Meta_Continuation);
6555 #ifdef MZTAG_REQUIRED
6556 resume_mc->type = scheme_rt_meta_cont;
6557 #endif
6558 resume_mc->prompt_tag = prompt_tag;
6559 if (p->meta_continuation) {
6560 resume_mc->next = p->meta_continuation;
6561 resume_mc->depth = p->meta_continuation->depth + 1;
6562 }
6563 resume_mc->meta_tail_pos = MZ_CONT_MARK_POS + 2;
6564 p->meta_continuation = resume_mc;
6565 }
6566
6567 if (scheme_setjmp(newbuf)) {
6568 /*
6569 We can get here in three ways:
6570 1. abort-current-continuation with this prompt's tag:
6571 In this case, p->cjs.jumping_to_continuation is the
6572 prompt, p->cjs.val is a value to deliver to the
6573 prompt handler, and p->cjs.is_escape is unset.
6574 [This is a jump in the normal error/abort chain.]
6575 2. applying a continuation that is delimited by the prompt tag
6576 (in which case the jump originates from scheme_do_eval):
6577 In this case, p->cjs.jumping_to_continuation is the
6578 prompt, p->cjs.val is a continuation, and
6579 p->cjs.is_escape is set.
6580 [This is a jump in the special continuation-application
6581 direct mode.]
6582 3. other exception-level escape:
6583 In this case, p->cjs.jumping_to_continuation is the
6584 target (maybe an escape continuation), p->cjs.val is
6585 information to propagate to the target, and p->cjs.is_escape
6586 is unset.
6587 [This is a jump in the normal error/abort chain.]
6588 */
6589 val = NULL;
6590 } else {
6591 val = _scheme_apply_multi(proc, argc, argv);
6592 }
6593
6594 p = scheme_current_thread;
6595 p->error_buf = savebuf;
6596
6597 {
6598 Scheme_Meta_Continuation *resume_mc;
6599 Scheme_Overflow *resume;
6600
6601 resume = p->meta_continuation->overflow;
6602 resume_mc = p->meta_continuation;
6603 p->meta_continuation = p->meta_continuation->next;
6604
6605 /* The following test was once useful for finding bugs. However,
6606 dropping meta-continuations that represent empty continuations
6607 (see for_composable in clone_meta_cont) interferes with the test. */
6608 /*
6609 if (!SAME_OBJ(resume_mc->prompt_tag, prompt_tag)) {
6610 scheme_signal_error("meta-continuation prompt tag does not match current prompt tag");
6611 }
6612 */
6613
6614 if (cc_count == scheme_cont_capture_count) {
6615 memset(resume_mc, 0, sizeof(Scheme_Meta_Continuation));
6616 #ifdef MZTAG_REQUIRED
6617 resume_mc->type = scheme_rt_meta_cont;
6618 #endif
6619 available_prompt_mc = resume_mc;
6620 }
6621
6622 if (!resume) {
6623 /* We return NULL if there's an escape of some sort (see above),
6624 otherwise we return the result value. */
6625 return val;
6626 } else if (resume->eot) {
6627 /* There's nothing left in the continuation,
6628 so just end the thread. We havent restored
6629 the thread state from the prompt, so flush
6630 anything that might otherwise have a clean-up action: */
6631 MZ_RUNSTACK = NULL;
6632 MZ_RUNSTACK_START = NULL;
6633 MZ_CONT_MARK_STACK = 0;
6634 p->runstack_start = NULL;
6635 p->runstack = NULL;
6636 p->runstack_size = 0;
6637 p->runstack_saved = NULL;
6638 p->cont_mark_stack_segments = NULL;
6639 scheme_end_current_thread();
6640 return NULL;
6641 } else {
6642 /* Continue by jumping to a meta-continuation. If
6643 val, then p->cjs.jumping_to_continuation is unset,
6644 so it's ok to communicate val via p->cjs.val. The
6645 target for this jump is in compose_continuation(). */
6646 if (val) {
6647 if (val == SCHEME_MULTIPLE_VALUES) {
6648 if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
6649 p->values_buffer = NULL;
6650 }
6651 p->cjs.val = val;
6652 }
6653 p->stack_start = resume->stack_start;
6654 p->decompose_mc = resume_mc;
6655 scheme_longjmpup(&resume->jmp->cont);
6656 return NULL;
6657 }
6658 }
6659 }
6660
6661 MZ_DO_NOT_INLINE(Scheme_Object *scheme_apply_for_prompt(Scheme_Prompt *prompt, Scheme_Object *prompt_tag,
6662 Scheme_Object *proc, int argc, Scheme_Object **argv));
6663
scheme_apply_for_prompt(Scheme_Prompt * prompt,Scheme_Object * prompt_tag,Scheme_Object * proc,int argc,Scheme_Object ** argv)6664 Scheme_Object *scheme_apply_for_prompt(Scheme_Prompt *prompt, Scheme_Object *prompt_tag,
6665 Scheme_Object *proc, int argc, Scheme_Object **argv)
6666 {
6667 /* Grab stack address, then continue on with final step: */
6668 prompt->stack_boundary = PROMPT_STACK(proc);
6669
6670 proc = scheme_finish_apply_for_prompt(prompt, prompt_tag, proc, argc, argv);
6671
6672 return proc;
6673 }
6674
compose_continuation(Scheme_Cont * cont,int exec_chain,Scheme_Object * loop_prompt,int empty_to_next_mc)6675 static Scheme_Object *compose_continuation(Scheme_Cont *cont, int exec_chain,
6676 Scheme_Object *loop_prompt, int empty_to_next_mc)
6677 /* continuation arguments should be in `cont' already */
6678 {
6679 /* Apply continuation as composable. There may or may not
6680 be a prompt immediately wrapping this application, depending on
6681 whether the continuation was captured as composable. */
6682 Scheme_Overflow *overflow;
6683 Scheme_Overflow_Jmp *jmp;
6684 Scheme_Cont *saved;
6685 Scheme_Prompt *saved_meta_prompt;
6686 Scheme_Thread *p = scheme_current_thread;
6687
6688 scheme_about_to_move_C_stack();
6689
6690 reset_cjs(&p->cjs);
6691
6692 saved_meta_prompt = p->meta_prompt;
6693
6694 /* Grab a continuation so that we capture the current Scheme stack,
6695 etc.: */
6696 saved = grab_continuation(p, 1, 0, NULL, NULL, NULL, NULL, NULL, NULL, 0, 0, NULL);
6697
6698 if (p->meta_prompt)
6699 saved->prompt_stack_start = p->meta_prompt->stack_boundary;
6700
6701 overflow = MALLOC_ONE_RT(Scheme_Overflow);
6702 #ifdef MZTAG_REQUIRED
6703 overflow->type = scheme_rt_overflow;
6704 #endif
6705 overflow->prev = p->overflow;
6706 overflow->stack_start = p->stack_start;
6707
6708 jmp = MALLOC_ONE_RT(Scheme_Overflow_Jmp);
6709 #ifdef MZTAG_REQUIRED
6710 jmp->type = scheme_rt_overflow_jmp;
6711 #endif
6712 overflow->jmp = jmp;
6713
6714 saved->resume_to = overflow; /* used by eval to jump to current meta-continuation */
6715 offstack_cont = saved;
6716 saved = NULL;
6717
6718 scheme_init_jmpup_buf(&overflow->jmp->cont);
6719
6720 offstack_overflow = overflow;
6721 overflow = NULL; /* so it's not saved in the continuation */
6722
6723 if (scheme_setjmpup(&offstack_overflow->jmp->cont,
6724 offstack_overflow->jmp,
6725 p->stack_start)) {
6726 /* Returning. (Jumped here from finish_apply_for_prompt,
6727 scheme_compose_continuation, scheme_eval, or start_child.)
6728
6729 We can return for several reasons:
6730 1. We got a result value.
6731 In that case, p->cjs.val holds the value, and
6732 p->cjs.jumping_to_continuation is NULL.
6733 2. There's an escape, and p->cjs.jumping_to_continuation
6734 is set. It could be a prompt, in which case we're
6735 escaping to the prompt, or it could be an
6736 error escape. In the former case, we may or may not be
6737 applying a continuation at the target; see
6738 scheme_finish_apply_for_prompt() for those possibilities.
6739 */
6740 Scheme_Object *v;
6741 Scheme_Meta_Continuation *mc, *dmc;
6742
6743 p = scheme_current_thread;
6744
6745 dmc = p->decompose_mc;
6746 p->decompose_mc = NULL;
6747 saved = dmc->cont;
6748 overflow = dmc->overflow;
6749
6750 if (!p->cjs.jumping_to_continuation) {
6751 /* Got a result: */
6752 v = p->cjs.val;
6753 p->cjs.val = NULL;
6754 if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES)) {
6755 if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
6756 p->values_buffer = NULL;
6757 }
6758 } else {
6759 /* Some sort of escape, to be handled by the caller,
6760 or to be handled below if it's an escape to loop_prompt. */
6761 v = NULL;
6762 }
6763 mc = p->meta_continuation;
6764 p->meta_prompt = saved_meta_prompt; /* Set meta_prompt before restoring runstack,
6765 since GC erases meta-prompt-blocked portion
6766 on the runstack. */
6767 restore_continuation(saved, p, 1, v, NULL, 0,
6768 NULL,
6769 NULL, 0, NULL,
6770 1, !p->cjs.jumping_to_continuation,
6771 NULL, NULL);
6772
6773 p->meta_continuation = mc;
6774
6775 /* There can be two kinds of loops:
6776 1. An escape to the current prompt to invoke another
6777 continuation.
6778 2. A trampoline to turn a composable-continuation
6779 application into a tail call; in this case,
6780 jumping_to_continuation = #t. */
6781 if (!v && ((loop_prompt
6782 && SAME_OBJ((Scheme_Object *)p->cjs.jumping_to_continuation,
6783 loop_prompt)
6784 && p->cjs.is_escape)
6785 || (!loop_prompt
6786 && p->cjs.jumping_to_continuation
6787 && SCHEME_VECTORP((Scheme_Object *)p->cjs.jumping_to_continuation)))) {
6788 /* We'll handle this escape directly, to avoid re-computing
6789 saved and overflow. */
6790 cont = (Scheme_Cont *)p->cjs.val;
6791 if (SCHEME_VECTORP((Scheme_Object *)p->cjs.jumping_to_continuation)) {
6792 /* Instead of installing marks in `saved' now, ask `cont' to do it,
6793 since `cont' may have some of its own replacements. */
6794 cont->extra_marks = (Scheme_Object *)p->cjs.jumping_to_continuation;
6795 }
6796 reset_cjs(&p->cjs);
6797 /* The current meta-continuation may have changed since capture: */
6798 saved->meta_continuation = p->meta_continuation;
6799 /* Fall though to continuation application below. */
6800 } else {
6801 return v;
6802 }
6803 } else {
6804 saved = offstack_cont;
6805 overflow = offstack_overflow;
6806 offstack_cont = NULL;
6807 offstack_overflow = NULL;
6808 }
6809
6810 scheme_current_thread->suspend_break++;
6811
6812 /* Here's where we jump to the target: */
6813 cont->use_next_cont = saved;
6814 cont->resume_to = overflow;
6815 cont->empty_to_next_mc = (char)empty_to_next_mc;
6816 scheme_current_thread->stack_start = cont->prompt_stack_start;
6817 scheme_longjmpup(&cont->buf_ptr->buf);
6818
6819 ESCAPED_BEFORE_HERE;
6820 }
6821
continue_prompt_escape()6822 static void continue_prompt_escape()
6823 {
6824 Scheme_Thread *p = scheme_current_thread;
6825 Scheme_Prompt *targetc = (Scheme_Prompt *)p->cjs.jumping_to_continuation;
6826
6827 scheme_drop_prompt_meta_continuations(targetc->tag);
6828
6829 if ((!targetc->boundary_overflow_id && !p->overflow)
6830 || (targetc->boundary_overflow_id == p->overflow->id)) {
6831 /* Jump directly to the target. */
6832 scheme_longjmp(*targetc->prompt_buf, 1);
6833 } else {
6834 /* More hassle: need to unwind overflows to get to the prompt. */
6835 Scheme_Overflow *overflow = p->overflow;
6836 while (overflow->prev
6837 && (!overflow->prev->id
6838 || (overflow->prev->id != targetc->boundary_overflow_id))) {
6839 overflow = overflow->prev;
6840 }
6841 p->overflow = overflow;
6842 p->stack_start = overflow->stack_start;
6843 scheme_longjmpup(&overflow->jmp->cont);
6844 }
6845 }
6846
restore_from_prompt(Scheme_Prompt * prompt)6847 static void restore_from_prompt(Scheme_Prompt *prompt)
6848 {
6849 Scheme_Thread *p = scheme_current_thread;
6850
6851 while (MZ_RUNSTACK_START != scheme_prompt_runstack_boundary_start(prompt)) {
6852 MZ_RUNSTACK_START = p->runstack_saved->runstack_start;
6853 p->runstack_saved = p->runstack_saved->prev;
6854 }
6855
6856 MZ_RUNSTACK = MZ_RUNSTACK_START + prompt->runstack_boundary_offset;
6857 MZ_CONT_MARK_STACK = prompt->mark_boundary;
6858 MZ_CONT_MARK_POS = prompt->boundary_mark_pos;
6859
6860 p->runstack_size = prompt->runstack_size;
6861
6862 if (prompt->boundary_overflow_id) {
6863 while (p->overflow->id != prompt->boundary_overflow_id) {
6864 p->overflow = p->overflow->prev;
6865 }
6866 } else
6867 p->overflow = NULL;
6868 }
6869
prompt_unwind_dw(Scheme_Object * prompt_tag)6870 static void prompt_unwind_dw(Scheme_Object *prompt_tag)
6871 {
6872 int delta = 0;
6873 Scheme_Thread *p = scheme_current_thread;
6874
6875 while (p->dw && !SAME_OBJ(p->dw->prompt_tag, prompt_tag)) {
6876 delta += p->dw->next_meta;
6877 p->dw = p->dw->prev;
6878 }
6879 if (!p->dw) {
6880 scheme_signal_error("Lost prompt dynamic-wind record!\n");
6881 } else {
6882 delta += p->dw->next_meta;
6883 p->dw = p->dw->prev;
6884 p->next_meta += delta;
6885 }
6886 }
6887
prompt_unwind_one_dw(Scheme_Object * prompt_tag)6888 static void prompt_unwind_one_dw(Scheme_Object *prompt_tag)
6889 {
6890 Scheme_Thread *p = scheme_current_thread;
6891 if (!p->dw || !SAME_OBJ(p->dw->prompt_tag, prompt_tag)) {
6892 scheme_signal_error("Dynamic-wind record doesn't match prompt!\n");
6893 } else
6894 prompt_unwind_dw(prompt_tag);
6895 }
6896
chaperone_do_control(const char * name,int mode,Scheme_Object * init_guard,Scheme_Object * obj,int argc,Scheme_Object ** argv)6897 static Scheme_Object **chaperone_do_control(const char *name, int mode,
6898 Scheme_Object *init_guard, Scheme_Object *obj,
6899 int argc, Scheme_Object **argv)
6900 {
6901 Scheme_Chaperone *px;
6902 Scheme_Object **vals = argv;
6903 Scheme_Object *v;
6904 Scheme_Object *proc;
6905 int i, num_args;
6906
6907 while (1) {
6908 if (init_guard || !SCHEME_PROMPT_TAGP(obj)) {
6909 if (init_guard) {
6910 proc = init_guard;
6911 if (SAME_OBJ(NULL, scheme_values_proc))
6912 proc = NULL;
6913 px = NULL;
6914 } else {
6915 px = (Scheme_Chaperone *)obj;
6916 obj = px->prev;
6917
6918 if (!mode)
6919 proc = SCHEME_CAR(px->redirects);
6920 else {
6921 proc = SCHEME_CDR(px->redirects);
6922 if (mode == 1) {
6923 if (SCHEME_PAIRP(proc))
6924 proc = SCHEME_CAR(proc);
6925 } else {
6926 if (SCHEME_PAIRP(proc)) {
6927 proc = SCHEME_CDR(proc);
6928 if (mode == 2) {
6929 if (SCHEME_PAIRP(proc))
6930 proc = SCHEME_CAR(proc);
6931 } else {
6932 if (SCHEME_PAIRP(proc))
6933 proc = SCHEME_CDR(proc);
6934 else
6935 proc = NULL;
6936 }
6937 } else
6938 proc = NULL;
6939 }
6940 }
6941 }
6942
6943 if (proc) {
6944 if (mode == 3)
6945 v = scheme_apply(proc, argc, argv); /* with barrier */
6946 else
6947 v = _scheme_apply_multi(proc, argc, argv);
6948
6949 if (v == SCHEME_MULTIPLE_VALUES) {
6950 GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread;
6951 if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
6952 p->values_buffer = NULL;
6953 num_args = p->ku.multiple.count;
6954 vals = p->ku.multiple.array;
6955 p->ku.multiple.array = NULL;
6956 } else {
6957 num_args = 1;
6958 vals = MALLOC_N(Scheme_Object *, 1);
6959 vals[0] = v;
6960 }
6961
6962 /*
6963 * All kinds of proxies should return the same number of results
6964 * as the number of aborted values
6965 */
6966 if (num_args == 1 && num_args != argc)
6967 scheme_wrong_return_arity(name, argc, 1, (Scheme_Object **)(vals[0]), "\n in: use of redirecting procedure");
6968 else if (num_args != argc)
6969 scheme_wrong_return_arity(name, argc, num_args, vals, "\n in: use of redirecting procedure");
6970
6971 if (mode == 3) {
6972 if (!scheme_check_proc_arity(NULL, 1, 0, argc, vals)) {
6973 scheme_wrong_type("call/cc guard-wrapping function", "(procedure-arity-includes/c 2)", 0, -1, vals);
6974 }
6975 }
6976
6977 if (!init_guard) {
6978 if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) {
6979 for (i = 0; i < argc; i++) {
6980 if (!scheme_chaperone_of(vals[i], argv[i]))
6981 scheme_wrong_chaperoned(name, "value", argv[i], vals[i]);
6982 }
6983 }
6984 }
6985
6986 argv = vals;
6987 }
6988
6989 init_guard = NULL;
6990 } else {
6991 return vals;
6992 }
6993 }
6994 }
6995
chaperone_do_prompt_handler(Scheme_Object * obj,int argc,Scheme_Object ** argv)6996 static Scheme_Object **chaperone_do_prompt_handler(Scheme_Object *obj, int argc, Scheme_Object **argv)
6997 {
6998 return chaperone_do_control("call-with-continuation-prompt", 0, NULL, obj, argc, argv);
6999 }
7000
chaperone_do_abort(Scheme_Object * obj,int argc,Scheme_Object ** argv)7001 static Scheme_Object **chaperone_do_abort(Scheme_Object *obj, int argc, Scheme_Object **argv)
7002 {
7003 return chaperone_do_control("abort-current-continuation", 1, NULL, obj, argc, argv);
7004 }
7005
chaperone_do_cc_guard(Scheme_Object * cc_guard,Scheme_Object * obj,int argc,Scheme_Object ** argv)7006 static Scheme_Object **chaperone_do_cc_guard(Scheme_Object *cc_guard, Scheme_Object *obj, int argc, Scheme_Object **argv)
7007 {
7008 return chaperone_do_control("call-with-continuation-prompt", 2, cc_guard, obj, argc, argv);
7009 }
7010
chaperone_wrap_cc_guard(Scheme_Object * obj,Scheme_Object * proc)7011 static Scheme_Object *chaperone_wrap_cc_guard(Scheme_Object *obj, Scheme_Object *proc)
7012 {
7013 Scheme_Object *a[1], **a2;
7014
7015 a[0] = proc;
7016 a2 = chaperone_do_control("call-with-current-continuation", 3, NULL, obj, 1, a);
7017
7018 return a2[0];
7019 }
7020
do_cc_guard(Scheme_Object * v,Scheme_Object * cc_guard,Scheme_Object * chaperone)7021 static Scheme_Object *do_cc_guard(Scheme_Object *v, Scheme_Object *cc_guard, Scheme_Object *chaperone)
7022 {
7023 int argc;
7024 Scheme_Object **argv, *a[1];
7025
7026 if (v == SCHEME_MULTIPLE_VALUES) {
7027 GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread;
7028 if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
7029 p->values_buffer = NULL;
7030 argc = p->ku.multiple.count;
7031 argv = p->ku.multiple.array;
7032 p->ku.multiple.array = NULL;
7033 } else {
7034 a[0] = v;
7035 argv = a;
7036 argc = 1;
7037 }
7038
7039 if (!chaperone) chaperone = scheme_default_prompt_tag;
7040
7041 argv = chaperone_do_cc_guard(cc_guard, chaperone, argc, argv);
7042
7043 if (argc == 1)
7044 return argv[0];
7045 else
7046 return scheme_values(argc, argv);
7047 }
7048
call_with_prompt(int in_argc,Scheme_Object * in_argv[])7049 static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[])
7050 {
7051 Scheme_Object *v;
7052 Scheme_Thread *p = scheme_current_thread;
7053 Scheme_Object *proc = in_argv[0], *prompt_tag;
7054 Scheme_Prompt *prompt;
7055 int argc, handler_argument_error = 0;
7056 # define QUICK_PROMPT_ARGS 3
7057 Scheme_Object **argv, *a[QUICK_PROMPT_ARGS], *handler;
7058 Scheme_Cont_Frame_Data cframe;
7059 Scheme_Dynamic_Wind *prompt_dw;
7060 int cc_count = scheme_cont_capture_count;
7061 Scheme_Object *chaperone = NULL, *cc_guard = scheme_false;
7062
7063 argc = in_argc - 3;
7064 if (argc <= 0) {
7065 argc = 0;
7066 argv = NULL;
7067 } else {
7068 int i;
7069 if (argc <= QUICK_PROMPT_ARGS)
7070 argv = a;
7071 else
7072 argv = MALLOC_N(Scheme_Object *, argc);
7073 for (i = 0; i < argc; i++) {
7074 argv[i] = in_argv[i+3];
7075 }
7076 }
7077
7078 scheme_check_proc_arity("call-with-continuation-prompt", argc, 0, in_argc, in_argv);
7079 if (in_argc > 1) {
7080 /* Check if the prompt tag is proxied */
7081 if (!SCHEME_PROMPT_TAGP(in_argv[1])) {
7082 if (SCHEME_NP_CHAPERONEP(in_argv[1])
7083 && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(in_argv[1]))) {
7084 chaperone = in_argv[1];
7085 prompt_tag = SCHEME_CHAPERONE_VAL(in_argv[1]);
7086 } else {
7087 scheme_wrong_contract("call-with-continuation-prompt", "continuation-prompt-tag?",
7088 1, in_argc, in_argv);
7089 return NULL;
7090 }
7091 } else
7092 prompt_tag = in_argv[1];
7093 if (SAME_OBJ(prompt_tag, scheme_root_prompt_tag)) {
7094 root_prompt_tag_misuse("call-with-continuation-prompt");
7095 return NULL;
7096 }
7097 } else
7098 prompt_tag = scheme_default_prompt_tag;
7099
7100 if (in_argc > 2) {
7101 if (SCHEME_TRUEP(in_argv[2]) && !SCHEME_PROCP(in_argv[2]))
7102 scheme_wrong_contract("call-with-continuation-prompt", "(or/c procedure? #f)", 2, in_argc, in_argv);
7103 handler = in_argv[2];
7104 } else
7105 handler = scheme_false;
7106
7107 do {
7108 /* loop implements the default prompt handler */
7109
7110 if (available_regular_prompt) {
7111 /* `call-with-continuation-prompt' is used by `with-handlers' which might
7112 easily occur in a loop. Try to avoid allocation, even if only for unnested
7113 prompts. */
7114 prompt = available_regular_prompt;
7115 available_regular_prompt = NULL;
7116 } else
7117 prompt = MALLOC_ONE_TAGGED(Scheme_Prompt);
7118
7119 prompt->so.type = scheme_prompt_type;
7120
7121 prompt->tag = prompt_tag;
7122
7123 /* An abuse of the continuation-mark stack: to keep track of
7124 chaperoning guards on a continuation result, we mutate a mark
7125 that is keyed on prompt_cc_mark_key and that sits next to the
7126 prompt mark. This is an abuse, because marks are not supposed
7127 to be mutable, but we do that to keep the mark setting attached
7128 to a continuation (given that continuation marks are copied out
7129 and in for a saved and restored continuation). We don't run
7130 afoul of caching, which depends on immuatbility of marks,
7131 because we access the mark only by get_set_cont_mark_by_pos(). */
7132
7133 scheme_push_continuation_frame(&cframe);
7134 scheme_set_cont_mark(prompt_cc_guard_key, cc_guard); /* see "abuse" note above */
7135 scheme_set_cont_mark(SCHEME_PTR_VAL(prompt_tag), (Scheme_Object *)prompt);
7136
7137 /* Note: prompt save marks after the one corresponding to itself,
7138 so that restoring a continuation captured under the prompt
7139 doesn't re-install this prompt. (Instead, the prompt that applies
7140 is the one in the invocation context). */
7141
7142 ASSERT_SUSPEND_BREAK_ZERO();
7143
7144 initialize_prompt(p, prompt, NULL, 0);
7145
7146 if (p->overflow) {
7147 ensure_overflow_id(p->overflow);
7148 prompt->boundary_overflow_id = p->overflow->id;
7149 }
7150
7151 prompt->runstack_size = p->runstack_size;
7152
7153 if (available_prompt_dw) {
7154 prompt_dw = available_prompt_dw;
7155 available_prompt_dw = NULL;
7156 } else
7157 prompt_dw = MALLOC_ONE_RT(Scheme_Dynamic_Wind);
7158 #ifdef MZTAG_REQUIRED
7159 prompt_dw->type = scheme_rt_dyn_wind;
7160 #endif
7161 prompt_dw->prompt_tag = prompt_tag;
7162 if (p->dw) {
7163 prompt_dw->next_meta = p->next_meta;
7164 prompt_dw->prev = p->dw;
7165 prompt_dw->depth = p->dw->depth + 1;
7166 }
7167
7168 p->next_meta = 0;
7169 p->dw = prompt_dw;
7170 if (chaperone)
7171 prompt->has_chaperone = 1;
7172
7173 v = scheme_apply_for_prompt(prompt, prompt_tag, proc, argc, argv);
7174
7175 /* >> An escape can jump directly here, instead of going through the
7176 usual escape chain of setjmps. That means we need to reset everything,
7177 such as the runstack pointer. The information we need is in the
7178 prompt record. */
7179
7180 p = scheme_current_thread;
7181
7182 if (v == SCHEME_MULTIPLE_VALUES) {
7183 if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
7184 p->values_buffer = NULL;
7185 }
7186
7187 restore_from_prompt(prompt);
7188
7189 p->suspend_break = 0;
7190
7191 if (!v) {
7192 /* There was an escape. See scheme_finish_apply_for_prompt for the possibilities. */
7193 if (SAME_OBJ((Scheme_Object *)p->cjs.jumping_to_continuation,
7194 (Scheme_Object *)prompt)) {
7195 /* Jumping to this prompt, maybe to apply a different
7196 continuation... */
7197 if (p->cjs.is_escape) {
7198 /* Yes, a different continuation. That is, apply a non-functional continuation
7199 that is based on a (potentially) different prompt. The d-w record
7200 is already removed as necessary at the cont call site in "eval.c".
7201 Loop, in case we have a kind of tail-call to another such contionuation: */
7202 Scheme_Cont *target;
7203
7204 target = (Scheme_Cont *)p->cjs.val;
7205 reset_cjs(&p->cjs);
7206
7207 v = compose_continuation(target, 1, (Scheme_Object *)prompt, 0);
7208
7209 if (v) {
7210 /* Got a result: */
7211 if (v == SCHEME_MULTIPLE_VALUES) {
7212 if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
7213 p->values_buffer = NULL;
7214 }
7215 prompt_unwind_one_dw(prompt_tag);
7216 handler = NULL;
7217 } else {
7218 /* Escaping, maybe to here... */
7219 p = scheme_current_thread;
7220 if (SAME_OBJ((Scheme_Object *)p->cjs.jumping_to_continuation,
7221 (Scheme_Object *)prompt)) {
7222 /* Jump to here. If p->cjs.is_escape, then
7223 we want to apply a continuation --- again. */
7224 if (p->cjs.is_escape) {
7225 /* this should have been caught in compose_continuation */
7226 scheme_signal_error("escape-to-prompt escaped!");
7227 return NULL;
7228 } else {
7229 /* It's an abort to here, so fall though and
7230 pick up the values. */
7231 prompt_unwind_one_dw(prompt_tag);
7232 v = NULL;
7233 }
7234 } else if (p->cjs.is_escape) {
7235 /* We're trying to get to a prompt in this meta-continuation.
7236 Jump again. */
7237 continue_prompt_escape();
7238 return NULL;
7239 } else {
7240 /* Exception-level or call/ec escape. Continue jumping: */
7241 restore_from_prompt(prompt);
7242 prompt_unwind_one_dw(prompt_tag);
7243 scheme_longjmp(*p->error_buf, 1);
7244 return NULL;
7245 }
7246 }
7247 } else {
7248 /* It was an abort to here; fall through, which picks up
7249 p->cjs.val to deliver to the handler. First discard the
7250 dw record that we introduced. */
7251 prompt_unwind_one_dw(prompt_tag);
7252 v = NULL;
7253 }
7254
7255 /* At this point, v can be non-NULL if a continuation
7256 delivered a value. */
7257
7258 if (!v) {
7259 /* cancel any pending cc_guard: */
7260 get_set_cont_mark_by_pos(prompt_cc_guard_key, p, NULL, MZ_CONT_MARK_POS, scheme_false);
7261
7262 argc = p->cjs.num_vals;
7263
7264 if (argc == 1) {
7265 a[0] = p->cjs.val;
7266 argv = a;
7267 } else
7268 argv = (Scheme_Object **)p->cjs.val;
7269
7270 reset_cjs(&p->cjs);
7271
7272 /*
7273 * If the prompt tag is proxied, run the intercession function
7274 * and call the handler on its results
7275 */
7276 if (chaperone) {
7277 argv = chaperone_do_prompt_handler(chaperone, argc, argv);
7278 }
7279
7280 if (SAME_OBJ(handler, scheme_values_proc)) {
7281 v = scheme_values(argc, argv);
7282 if (v == SCHEME_MULTIPLE_VALUES) {
7283 if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
7284 p->values_buffer = NULL;
7285 }
7286 handler = NULL;
7287 } else if (SCHEME_FALSEP(handler)) {
7288 if (argc == 1) {
7289 if (!scheme_check_proc_arity(NULL, 0, 0, argc, argv)) {
7290 /* delay error until we clean up: */
7291 handler_argument_error = 1;
7292 handler = NULL;
7293 } else {
7294 proc = a[0];
7295 argc = 0;
7296 argv = NULL;
7297 }
7298 } else {
7299 /* wrong number of arguments returned to default handler */
7300 handler_argument_error = 1;
7301 handler = NULL;
7302 }
7303 }
7304 } else {
7305 argc = 0;
7306 argv = NULL;
7307 }
7308 } else {
7309 /* Other error-like escape: */
7310 if ((p->dw != prompt_dw)
7311 && (!p->dw || !prompt_dw->id || (p->dw->id != prompt_dw->id))) {
7312 /* A full continuation jump was interrupted by an
7313 escape continuation jump (in a dw pre or post thunk). */
7314 } else
7315 prompt_unwind_one_dw(prompt_tag);
7316 scheme_longjmp(*p->error_buf, 1);
7317 return NULL;
7318 }
7319 } else {
7320 prompt_unwind_one_dw(prompt_tag);
7321 handler = NULL;
7322 argc = 0;
7323 argv = NULL;
7324 }
7325
7326 cc_guard = get_set_cont_mark_by_pos(prompt_cc_guard_key, p, NULL, MZ_CONT_MARK_POS, NULL);
7327 if (SCHEME_FALSEP(cc_guard)) cc_guard = NULL;
7328
7329 scheme_pop_continuation_frame(&cframe);
7330
7331 if (cc_count == scheme_cont_capture_count) {
7332 if (!available_regular_prompt) {
7333 memset(prompt, 0, sizeof(Scheme_Prompt));
7334 prompt->so.type = scheme_prompt_type;
7335 available_regular_prompt = prompt;
7336 }
7337 if (!available_prompt_dw) {
7338 memset(prompt_dw, 0, sizeof(Scheme_Dynamic_Wind));
7339 #ifdef MZTAG_REQUIRED
7340 prompt_dw->type = scheme_rt_dyn_wind;
7341 #endif
7342 available_prompt_dw = prompt_dw;
7343 }
7344 }
7345 } while (handler && SCHEME_FALSEP(handler));
7346
7347 if (handler_argument_error) {
7348 if (argc == 1) {
7349 scheme_check_proc_arity("default-continuation-prompt-handler", 0, 0, argc, argv);
7350 } else {
7351 scheme_wrong_return_arity("call-with-continuation-prompt", 1, argc, argv,
7352 "\n in: application of default prompt handler");
7353 }
7354 }
7355
7356 if (handler) {
7357 return _scheme_tail_apply(handler, argc, argv);
7358 } else if (cc_guard) {
7359 if (SAME_OBJ(cc_guard, scheme_values_proc))
7360 cc_guard = NULL;
7361 if (cc_guard || chaperone)
7362 return do_cc_guard(v, cc_guard, chaperone);
7363 else
7364 return v;
7365 } else
7366 return v;
7367 }
7368
propagate_abort(int argc,Scheme_Object ** argv)7369 static Scheme_Object *propagate_abort(int argc, Scheme_Object **argv)
7370 {
7371 Scheme_Object **argv2;
7372
7373 argv2 = MALLOC_N(Scheme_Object *, argc + 1);
7374 memcpy(argv2 XFORM_OK_PLUS 1, argv, sizeof(Scheme_Object *) * argc);
7375 argv2[0] = scheme_default_prompt_tag;
7376
7377 return _scheme_apply(abort_continuation_proc, argc+1, argv2);
7378 }
7379
do_call_with_prompt(Scheme_Closed_Prim f,void * data,int multi,int top_level)7380 static Scheme_Object *do_call_with_prompt(Scheme_Closed_Prim f, void *data,
7381 int multi, int top_level)
7382 {
7383 Scheme_Object *prim, *a[3];
7384
7385 prim = scheme_make_closed_prim(f, data);
7386 a[0] = prim;
7387 a[1] = scheme_default_prompt_tag;
7388 a[2] = propagate_abort_prim;
7389
7390 if (multi) {
7391 if (top_level)
7392 return scheme_apply_multi(call_with_prompt_proc, 3, a);
7393 else
7394 return _scheme_apply_multi(call_with_prompt_proc, 3, a);
7395 } else {
7396 if (top_level)
7397 return scheme_apply(call_with_prompt_proc, 3, a);
7398 else
7399 return _scheme_apply(call_with_prompt_proc, 3, a);
7400 }
7401 }
7402
scheme_call_with_prompt(Scheme_Closed_Prim f,void * data)7403 Scheme_Object *scheme_call_with_prompt(Scheme_Closed_Prim f, void *data)
7404 {
7405 return do_call_with_prompt(f, data, 0, 1);
7406 }
7407
scheme_call_with_prompt_multi(Scheme_Closed_Prim f,void * data)7408 Scheme_Object *scheme_call_with_prompt_multi(Scheme_Closed_Prim f, void *data)
7409 {
7410 return do_call_with_prompt(f, data, 1, 1);
7411 }
7412
_scheme_call_with_prompt(Scheme_Closed_Prim f,void * data)7413 Scheme_Object *_scheme_call_with_prompt(Scheme_Closed_Prim f, void *data)
7414 {
7415 return do_call_with_prompt(f, data, 0, 0);
7416 }
7417
_scheme_call_with_prompt_multi(Scheme_Closed_Prim f,void * data)7418 Scheme_Object *_scheme_call_with_prompt_multi(Scheme_Closed_Prim f, void *data)
7419 {
7420 return do_call_with_prompt(f, data, 1, 0);
7421 }
7422
scheme_compose_continuation(Scheme_Cont * cont,int num_rands,Scheme_Object * value)7423 Scheme_Object *scheme_compose_continuation(Scheme_Cont *cont, int num_rands, Scheme_Object *value)
7424 {
7425 Scheme_Meta_Continuation *mc;
7426 int empty_to_next_mc;
7427
7428 if (num_rands != 1) {
7429 value = scheme_values(num_rands, (Scheme_Object **)value);
7430 {
7431 Scheme_Thread *p = scheme_current_thread;
7432 if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
7433 p->values_buffer = NULL;
7434 }
7435 }
7436 cont->value = value;
7437 cont->common_dw_depth = -1;
7438
7439 mc = scheme_current_thread->meta_continuation;
7440 if (mc && mc->pseudo && mc->meta_tail_pos == MZ_CONT_MARK_POS) {
7441 /* The existing meta-continuation is the same as the
7442 current continuation. Trampoline through the meta-continuation
7443 to implement the call as a tail call.
7444 We also need to propagate continuation marks here, if any,
7445 back to the trampoline. They get merged with the trampoline's
7446 meta-continuation when `cont' is applied. */
7447 Scheme_Thread *p = scheme_current_thread;
7448 Scheme_Object *cm_info;
7449 intptr_t findpos, bottom, pos;
7450 int count, mcount, i;
7451
7452 p->meta_continuation = mc->next;
7453
7454 bottom = (intptr_t)p->cont_mark_stack_bottom;
7455 count = 0;
7456 for (findpos = (intptr_t)MZ_CONT_MARK_STACK - 1; findpos >= bottom; findpos--) {
7457 GC_CAN_IGNORE Scheme_Cont_Mark *seg;
7458
7459 seg = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE];
7460 pos = findpos & SCHEME_MARK_SEGMENT_MASK;
7461 if (seg[pos].pos != MZ_CONT_MARK_POS)
7462 break;
7463 count++;
7464 }
7465 mcount = 0;
7466 for (findpos = (intptr_t)mc->cont_mark_total; findpos--; ) {
7467 if (mc->cont_mark_stack_copied[findpos].pos != mc->cont_mark_pos)
7468 break;
7469 mcount++;
7470 }
7471
7472 cm_info = scheme_make_vector((count + mcount) * 2, NULL);
7473 for (findpos = (intptr_t)MZ_CONT_MARK_STACK - 1, i = 0; i < count; findpos--, i++) {
7474 GC_CAN_IGNORE Scheme_Cont_Mark *seg;
7475
7476 seg = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE];
7477 pos = findpos & SCHEME_MARK_SEGMENT_MASK;
7478 SCHEME_VEC_ELS(cm_info)[2*i] = seg[pos].key;
7479 SCHEME_VEC_ELS(cm_info)[(2*i)+1] = seg[pos].val;
7480 }
7481 for (findpos = (intptr_t)mc->cont_mark_total - 1, i = 0; i < mcount; findpos--, i++) {
7482 SCHEME_VEC_ELS(cm_info)[2*(count + i)] = mc->cont_mark_stack_copied[findpos].key;
7483 SCHEME_VEC_ELS(cm_info)[(2*(count + i))+1] = mc->cont_mark_stack_copied[findpos].val;
7484 }
7485
7486 p->cjs.jumping_to_continuation = cm_info; /* vector => trampoline */
7487 p->cjs.alt_full_continuation = NULL;
7488 p->cjs.val = (Scheme_Object *)cont;
7489 p->cjs.num_vals = 1;
7490 p->cjs.is_escape = 1;
7491 p->cjs.skip_dws = 0;
7492
7493 p->stack_start = mc->overflow->stack_start;
7494 p->decompose_mc = mc;
7495
7496 scheme_longjmpup(&mc->overflow->jmp->cont);
7497 return NULL;
7498 } else if (mc && mc->meta_tail_pos == MZ_CONT_MARK_POS) {
7499 empty_to_next_mc = 1;
7500 } else {
7501 empty_to_next_mc = 0;
7502 }
7503
7504 /* Clear to avoid retaining a chain of meta-continuationss: */
7505 mc = NULL;
7506
7507 value = compose_continuation(cont, 0, NULL, empty_to_next_mc);
7508
7509 scheme_current_thread->next_meta -= 1;
7510
7511 if (!value) {
7512 /* Continue escape --- maybe a direct jump to a prompt
7513 in this meta-continuation. */
7514 Scheme_Thread *p = scheme_current_thread;
7515 if (p->cjs.is_escape) {
7516 /* We're trying to get to a prompt in this meta-continuation.
7517 Jump again. */
7518 continue_prompt_escape();
7519 } else {
7520 scheme_longjmp(*scheme_current_thread->error_buf, 1);
7521 }
7522 }
7523
7524 return value;
7525 }
7526
do_abort_continuation(int argc,Scheme_Object * argv[],int skip_dws)7527 static Scheme_Object *do_abort_continuation (int argc, Scheme_Object *argv[], int skip_dws)
7528 {
7529 Scheme_Object *prompt_tag;
7530 Scheme_Prompt *prompt;
7531 Scheme_Thread *p = scheme_current_thread;
7532 Scheme_Object *a[1];
7533 Scheme_Object **vals;
7534 int is_chaperoned = 0;
7535
7536 if (!SCHEME_PROMPT_TAGP(argv[0])) {
7537 /* Check if the prompt tag is proxied */
7538 if (SCHEME_NP_CHAPERONEP(argv[0])
7539 && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(argv[0]))) {
7540 is_chaperoned = 1;
7541 prompt_tag = SCHEME_CHAPERONE_VAL(argv[0]);
7542 } else {
7543 scheme_wrong_contract("abort-current-continuation", "continuation-prompt-tag?",
7544 0, argc, argv);
7545 return NULL;
7546 }
7547 } else
7548 prompt_tag = argv[0];
7549
7550 if (SAME_OBJ(prompt_tag, scheme_root_prompt_tag)) {
7551 root_prompt_tag_misuse("abort-current-continuation");
7552 return NULL;
7553 }
7554
7555 prompt = (Scheme_Prompt *)scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(prompt_tag));
7556 if (!prompt && SAME_OBJ(scheme_default_prompt_tag, prompt_tag))
7557 prompt = original_default_prompt;
7558
7559 if (!prompt) {
7560 scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
7561 "abort-current-continuation: continuation includes no prompt with the given tag\n"
7562 " tag: %V",
7563 prompt_tag);
7564 return NULL;
7565 }
7566
7567 if (argc == 2) {
7568 p->cjs.num_vals = 1;
7569 /*
7570 * If the prompt tag isn't proxied, continue with the aborted value.
7571 * Otherwise, run the intercession function and then continue with its
7572 * new results.
7573 */
7574 if (!is_chaperoned)
7575 p->cjs.val = argv[1];
7576 else {
7577 a[0] = argv[1];
7578 vals = chaperone_do_abort(argv[0], 1, a);
7579 p->cjs.val = (Scheme_Object *)vals[0];
7580 }
7581 } else {
7582 int i;
7583 vals = MALLOC_N(Scheme_Object *, argc - 1);
7584 for (i = argc; i-- > 1; ) {
7585 vals[i-1] = argv[i];
7586 }
7587 p->cjs.num_vals = argc - 1;
7588 if (!is_chaperoned)
7589 p->cjs.val = (Scheme_Object *)vals;
7590 else {
7591 vals = chaperone_do_abort(argv[0], argc - 1, vals);
7592 p->cjs.val = (Scheme_Object *)vals;
7593 }
7594 }
7595 p->cjs.jumping_to_continuation = (Scheme_Object *)prompt;
7596 p->cjs.alt_full_continuation = NULL;
7597 p->cjs.skip_dws = skip_dws;
7598
7599 scheme_longjmp(*p->error_buf, 1);
7600
7601 return NULL;
7602 }
7603
abort_continuation(int argc,Scheme_Object * argv[])7604 static Scheme_Object *abort_continuation (int argc, Scheme_Object *argv[])
7605 {
7606 return do_abort_continuation(argc, argv, 0);
7607 }
7608
scheme_abort_continuation_no_dws(Scheme_Object * pt,Scheme_Object * v)7609 Scheme_Object *scheme_abort_continuation_no_dws (Scheme_Object *pt, Scheme_Object *v)
7610 {
7611 /* This function is useful for GRacket-like extensions of Racket that need to
7612 implement something like subtreads through composable continuations. */
7613 Scheme_Object *a[2];
7614
7615 a[0] = pt;
7616 a[1] = v;
7617
7618 return do_abort_continuation(2, a, 1);
7619 }
7620
unsafe_abort_continuation_no_dws(int argc,Scheme_Object * argv[])7621 static Scheme_Object *unsafe_abort_continuation_no_dws(int argc, Scheme_Object *argv[])
7622 {
7623 /* See scheme_abort_continuation_no_dws() */
7624 return do_abort_continuation(argc, argv, 1);
7625 }
7626
do_call_with_control(int argc,Scheme_Object * argv[],int no_dws)7627 static Scheme_Object *do_call_with_control (int argc, Scheme_Object *argv[], int no_dws)
7628 {
7629 Scheme_Object *prompt_tag;
7630 Scheme_Object *a[3];
7631
7632 scheme_check_proc_arity("call-with-composable-continuation", 1, 0, argc, argv);
7633 if (argc > 1) {
7634 prompt_tag = argv[1];
7635 if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(prompt_tag))) {
7636 if (SCHEME_NP_CHAPERONEP(prompt_tag)
7637 && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(prompt_tag)))
7638 prompt_tag = SCHEME_CHAPERONE_VAL(prompt_tag);
7639 else {
7640 scheme_wrong_contract("call-with-composable-continuation", "continuation-prompt-tag?",
7641 1, argc, argv);
7642 return NULL;
7643 }
7644 }
7645 if (SAME_OBJ(prompt_tag, scheme_root_prompt_tag)) {
7646 root_prompt_tag_misuse("abort-current-continuation");
7647 return NULL;
7648 }
7649 } else
7650 prompt_tag = scheme_default_prompt_tag;
7651
7652 a[0] = argv[0];
7653 a[1] = prompt_tag;
7654 a[2] = (no_dws ? scheme_true : scheme_false);
7655
7656 /* Trampoline to internal_call_cc. This trampoline ensures that
7657 the runstack is flushed before we try to grab the continuation. */
7658 return _scheme_tail_apply(internal_call_cc_prim, 3, a);
7659 }
7660
call_with_control(int argc,Scheme_Object * argv[])7661 static Scheme_Object *call_with_control (int argc, Scheme_Object *argv[])
7662 {
7663 return do_call_with_control(argc, argv, 0);
7664 }
7665
scheme_call_with_composable_no_dws(Scheme_Object * proc,Scheme_Object * pt)7666 Scheme_Object *scheme_call_with_composable_no_dws (Scheme_Object *proc, Scheme_Object *pt)
7667 {
7668 /* Works with scheme_abort_continuation_no_dws() above. */
7669 Scheme_Object *a[2];
7670
7671 a[0] = proc;
7672 a[1] = pt;
7673
7674 return do_call_with_control(2, a, 1);
7675 }
7676
unsafe_call_with_control_no_dws(int argc,Scheme_Object * argv[])7677 static Scheme_Object *unsafe_call_with_control_no_dws(int argc, Scheme_Object *argv[])
7678 {
7679 /* See scheme_call_with_composable_no_dws() */
7680 return do_call_with_control(argc, argv, 1);
7681 }
7682
unsafe_root_continuation_prompt_tag(int argc,Scheme_Object * argv[])7683 static Scheme_Object *unsafe_root_continuation_prompt_tag(int argc, Scheme_Object *argv[])
7684 {
7685 return scheme_root_prompt_tag;
7686 }
7687
copy_cm_shared_on_write(Scheme_Meta_Continuation * mc)7688 static Scheme_Cont_Mark *copy_cm_shared_on_write(Scheme_Meta_Continuation *mc)
7689 {
7690 Scheme_Cont_Mark *cp;
7691
7692 cp = MALLOC_N(Scheme_Cont_Mark, mc->cont_mark_total);
7693 memcpy(cp, mc->cont_mark_stack_copied, mc->cont_mark_total * sizeof(Scheme_Cont_Mark));
7694 mc->cont_mark_stack_copied = cp;
7695 mc->cm_shared = 0;
7696
7697 return cp;
7698 }
7699
continuation_marks(Scheme_Thread * p,Scheme_Object * _cont,Scheme_Object * econt,Scheme_Meta_Continuation * mc,Scheme_Object * prompt_tag,const char * who,int just_chain,int use_boundary_prompt)7700 static Scheme_Object *continuation_marks(Scheme_Thread *p,
7701 Scheme_Object *_cont,
7702 Scheme_Object *econt,
7703 Scheme_Meta_Continuation *mc,
7704 Scheme_Object *prompt_tag,
7705 const char *who,
7706 int just_chain,
7707 int use_boundary_prompt)
7708 /* cont => p is not used */
7709 {
7710 Scheme_Cont *cont = (Scheme_Cont *)_cont, *top_cont;
7711 Scheme_Cont_Mark_Chain *first = NULL, *last = NULL;
7712 Scheme_Cont_Mark_Set *set;
7713 Scheme_Object *cache, *nt;
7714 intptr_t findpos, bottom;
7715 intptr_t cmpos, first_cmpos = 0, cdelta = 0;
7716 int found_tag = 0, at_mc_boundary = 0;
7717
7718 if (SAME_OBJ(prompt_tag, scheme_root_prompt_tag))
7719 prompt_tag = NULL;
7720
7721 if (cont
7722 && (use_boundary_prompt || !cont->composable)
7723 && SAME_OBJ(cont->prompt_tag, prompt_tag))
7724 found_tag = 1;
7725 if (!prompt_tag)
7726 found_tag = 1;
7727
7728 do {
7729 if (econt) {
7730 findpos = (intptr_t)((Scheme_Escaping_Cont *)econt)->envss.cont_mark_stack;
7731 cmpos = (intptr_t)((Scheme_Escaping_Cont *)econt)->envss.cont_mark_pos;
7732 if (mc) {
7733 cdelta = mc->cont_mark_offset;
7734 bottom = 0;
7735 } else
7736 bottom = p->cont_mark_stack_bottom;
7737 } else if (cont) {
7738 findpos = (intptr_t)cont->ss.cont_mark_stack;
7739 cmpos = (intptr_t)cont->ss.cont_mark_pos;
7740 cdelta = cont->cont_mark_offset;
7741 bottom = 0;
7742 } else if (mc) {
7743 findpos = (intptr_t)mc->cont_mark_stack;
7744 cmpos = (intptr_t)mc->cont_mark_pos;
7745 cdelta = mc->cont_mark_offset;
7746 bottom = 0;
7747 at_mc_boundary = 1;
7748 } else {
7749 findpos = (intptr_t)MZ_CONT_MARK_STACK;
7750 cmpos = (intptr_t)MZ_CONT_MARK_POS;
7751 if (!p->cont_mark_stack_segments)
7752 findpos = 0;
7753 bottom = p->cont_mark_stack_bottom;
7754 }
7755
7756 top_cont = cont;
7757
7758 while (findpos-- > bottom) {
7759 Scheme_Cont_Mark *find;
7760 intptr_t pos;
7761
7762 if (cont) {
7763 while (findpos < cdelta) {
7764 if (!cont->runstack_copied) {
7765 /* Current cont was just a mark-stack variation of
7766 next cont, so skip the next cont. */
7767 cont = cont->buf_ptr->buf.cont;
7768 }
7769 cont = cont->buf_ptr->buf.cont;
7770 if (cont)
7771 cdelta = cont->cont_mark_offset;
7772 else
7773 break;
7774 }
7775 if (!cont)
7776 break;
7777 find = cont->cont_mark_stack_copied;
7778 pos = findpos - cdelta;
7779 } else if (mc) {
7780 if (findpos < cdelta)
7781 break;
7782 find = mc->cont_mark_stack_copied;
7783 pos = findpos - cdelta;
7784 } else {
7785 GC_CAN_IGNORE Scheme_Cont_Mark *seg;
7786
7787 seg = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE];
7788 pos = findpos & SCHEME_MARK_SEGMENT_MASK;
7789 find = seg;
7790 }
7791
7792 /* A cache is one of:
7793 NULL (empty)
7794 #f (empty)
7795 hash-table: maps prompt tag to tag-cache
7796 chain : for default_scheme_prompt_tag
7797 (vector chain key val depth) : chain is for default_scheme_prompt_tag,
7798 key+val+depth is for !prompt_tag
7799
7800 A tag-cache is one of:
7801 chain : the chain we're looking for
7802 (vector chain key val depth) : key = NULL implies that val is
7803 a table of mappings from keys to (cons val depth)s
7804 */
7805
7806 if (prompt_tag && (find[pos].key == SCHEME_PTR_VAL(prompt_tag))) {
7807 found_tag = 1;
7808 /* Break out of outer loop, too: */
7809 mc = NULL;
7810 p = NULL;
7811 econt = NULL;
7812 cont = NULL;
7813 top_cont = NULL;
7814 break;
7815 }
7816
7817 cache = find[pos].cache;
7818 if (cache) {
7819 if (SCHEME_FALSEP(cache))
7820 cache = NULL;
7821 if (cache) {
7822 if (SCHEME_HASHTP(cache))
7823 cache = scheme_eq_hash_get((Scheme_Hash_Table *)cache, prompt_tag ? prompt_tag : scheme_false);
7824 else if (prompt_tag != scheme_default_prompt_tag)
7825 cache = NULL;
7826 }
7827 if (cache && SCHEME_VECTORP(cache)) {
7828 cache = SCHEME_VEC_ELS(cache)[0];
7829 }
7830 }
7831
7832 if (cache) {
7833 if (((Scheme_Cont_Mark_Chain *)cache)->key) {
7834 if (last) {
7835 last->next = (Scheme_Cont_Mark_Chain *)cache;
7836 if (at_mc_boundary) {
7837 SCHEME_MARK_CHAIN_FLAG(last) |= 0x1;
7838 at_mc_boundary = 0;
7839 }
7840 } else {
7841 first = (Scheme_Cont_Mark_Chain *)cache;
7842 first_cmpos = cmpos;
7843 }
7844
7845 found_tag = 1; /* cached => tag is there */
7846 } else {
7847 /* bogus: tag wasn't there when we cached this chain */
7848 }
7849
7850 /* Break out of outer loop, too: */
7851 mc = NULL;
7852 p = NULL;
7853 econt = NULL;
7854 cont = NULL;
7855 top_cont = NULL;
7856
7857 break;
7858 } else {
7859 Scheme_Cont_Mark_Chain *pr;
7860 pr = MALLOC_ONE_RT(Scheme_Cont_Mark_Chain);
7861 pr->iso.so.type = scheme_cont_mark_chain_type;
7862 pr->key = find[pos].key;
7863 pr->val = find[pos].val;
7864 pr->pos = find[pos].pos;
7865 pr->next = NULL;
7866 if (mc) {
7867 if (mc->cm_shared)
7868 find = copy_cm_shared_on_write(mc);
7869 mc->cm_caches = 1;
7870 }
7871 cache = find[pos].cache;
7872 if (cache && !SCHEME_FALSEP(cache)) {
7873 if (SCHEME_HASHTP(cache)) {
7874 Scheme_Hash_Table *ht = (Scheme_Hash_Table *)cache;
7875 cache = scheme_eq_hash_get(ht, prompt_tag ? prompt_tag : scheme_false);
7876 if (!cache) {
7877 scheme_hash_set(ht, prompt_tag ? prompt_tag : scheme_false, (Scheme_Object *)pr);
7878 } else {
7879 /* cache must be a vector */
7880 SCHEME_VEC_ELS(cache)[0] = (Scheme_Object *)pr;
7881 }
7882 } else if (!SCHEME_VECTORP(cache)) {
7883 /* cache is a chain and the tag is not the default prompt tag */
7884 Scheme_Hash_Table *ht;
7885 ht = scheme_make_hash_table(SCHEME_hash_ptr);
7886 scheme_hash_set(ht, scheme_default_prompt_tag, cache);
7887 scheme_hash_set(ht, prompt_tag ? prompt_tag : scheme_false, (Scheme_Object *)pr);
7888 find[pos].cache = (Scheme_Object *)ht;
7889 } else {
7890 /* cache must be a vector */
7891 if (prompt_tag == scheme_default_prompt_tag)
7892 SCHEME_VEC_ELS(cache)[0] = (Scheme_Object *)pr;
7893 else {
7894 /* Need to split up the default and NULL tags. Don't
7895 try to use cache for just the null tag, in case
7896 it's use by other copies. */
7897 Scheme_Hash_Table *ht;
7898 Scheme_Object *vec;
7899 ht = scheme_make_hash_table(SCHEME_hash_ptr);
7900 vec = scheme_make_vector(4, NULL);
7901 SCHEME_VEC_ELS(vec)[1] = SCHEME_VEC_ELS(cache)[1];
7902 SCHEME_VEC_ELS(vec)[2] = SCHEME_VEC_ELS(cache)[2];
7903 SCHEME_VEC_ELS(vec)[3] = SCHEME_VEC_ELS(cache)[3];
7904 scheme_hash_set(ht, scheme_false, vec);
7905 if (!prompt_tag)
7906 SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)pr;
7907 else
7908 scheme_hash_set(ht, prompt_tag, (Scheme_Object *)pr);
7909 find[pos].cache = (Scheme_Object *)ht;
7910 }
7911 }
7912 } else if (prompt_tag == scheme_default_prompt_tag) {
7913 find[pos].cache = (Scheme_Object *)pr;
7914 } else {
7915 cache = (Scheme_Object *)scheme_make_hash_table(SCHEME_hash_ptr);
7916 scheme_hash_set((Scheme_Hash_Table *)cache,
7917 prompt_tag ? prompt_tag : scheme_false,
7918 (Scheme_Object *)pr);
7919 find[pos].cache = cache;
7920 }
7921 if (last) {
7922 last->next = pr;
7923 if (at_mc_boundary) {
7924 SCHEME_MARK_CHAIN_FLAG(last) |= 1;
7925 at_mc_boundary = 0;
7926 }
7927 } else {
7928 first = pr;
7929 first_cmpos = cmpos;
7930 }
7931
7932 last = pr;
7933 }
7934 }
7935
7936 if (mc) {
7937 mc = mc->next;
7938 } else if (top_cont) {
7939 mc = top_cont->meta_continuation;
7940 } else if (econt) {
7941 mc = p->meta_continuation;
7942 } else if (p) {
7943 mc = p->meta_continuation;
7944 }
7945 cont = NULL;
7946 econt = NULL;
7947 p = NULL;
7948 } while (mc);
7949
7950 if (!found_tag) {
7951 if (!SAME_OBJ(prompt_tag, scheme_default_prompt_tag)) {
7952 /* The chain is cached. Destroy it, so that future cache references
7953 will indicate that the tag is not present (as opposed to delivering
7954 the bogus chain). */
7955 while (first) {
7956 first->key = NULL;
7957 first = first->next;
7958 }
7959 if (!who)
7960 return NULL;
7961 scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
7962 "%s: no corresponding prompt in the continuation\n"
7963 " tag: %V",
7964 who, prompt_tag);
7965 } else if (!use_boundary_prompt) {
7966 /* Don't treat default tag as found */
7967 return NULL;
7968 }
7969 }
7970
7971 if (just_chain)
7972 return (Scheme_Object *)first;
7973
7974 #ifdef MZ_USE_JIT
7975 if (_cont)
7976 nt = ((Scheme_Cont *)_cont)->native_trace;
7977 else if (econt)
7978 nt = ((Scheme_Escaping_Cont *)econt)->native_trace;
7979 else
7980 nt = scheme_native_stack_trace();
7981 #else
7982 nt = NULL;
7983 #endif
7984
7985 if (first && (first_cmpos < first->pos)) {
7986 /* Don't use scheme_signal_error(), because that will try to get
7987 a continuation mark... */
7988 scheme_log_abort("internal error: bad mark-stack position");
7989 abort();
7990 }
7991
7992 set = MALLOC_ONE_TAGGED(Scheme_Cont_Mark_Set);
7993 set->so.type = scheme_cont_mark_set_type;
7994 set->chain = first;
7995 set->cmpos = first_cmpos;
7996 set->native_stack_trace = nt;
7997
7998 return (Scheme_Object *)set;
7999 }
8000
make_empty_marks()8001 static Scheme_Object *make_empty_marks()
8002 {
8003 /* empty marks */
8004 Scheme_Cont_Mark_Set *set;
8005
8006 set = MALLOC_ONE_TAGGED(Scheme_Cont_Mark_Set);
8007 set->so.type = scheme_cont_mark_set_type;
8008 set->chain = NULL;
8009 set->cmpos = 1;
8010 set->native_stack_trace = NULL;
8011
8012 return (Scheme_Object *)set;
8013 }
8014
scheme_current_continuation_marks_as(const char * who,Scheme_Object * prompt_tag)8015 Scheme_Object *scheme_current_continuation_marks_as(const char *who, Scheme_Object *prompt_tag)
8016 /* if who is NULL, the result can be NULL instead of a prompt-tag error */
8017 {
8018 return continuation_marks(scheme_current_thread, NULL, NULL, NULL,
8019 prompt_tag ? prompt_tag : scheme_default_prompt_tag,
8020 who,
8021 0, 1);
8022 }
8023
scheme_current_continuation_marks(Scheme_Object * prompt_tag)8024 Scheme_Object *scheme_current_continuation_marks(Scheme_Object *prompt_tag)
8025 {
8026 return scheme_current_continuation_marks_as("continuation-marks", prompt_tag);
8027 }
8028
scheme_all_current_continuation_marks()8029 Scheme_Object *scheme_all_current_continuation_marks()
8030 {
8031 return continuation_marks(scheme_current_thread, NULL, NULL, NULL,
8032 NULL,
8033 "continuation-marks",
8034 0, 1);
8035 }
8036
current_mark_chain(const char * who,Scheme_Object * prompt_tag)8037 Scheme_Cont_Mark_Chain *current_mark_chain(const char *who, Scheme_Object *prompt_tag) {
8038 return (Scheme_Cont_Mark_Chain *)continuation_marks(scheme_current_thread, NULL, NULL, NULL,
8039 prompt_tag,
8040 who,
8041 1, 1);
8042 }
8043
8044 static Scheme_Object *
cc_marks(int argc,Scheme_Object * argv[])8045 cc_marks(int argc, Scheme_Object *argv[])
8046 {
8047 Scheme_Object *prompt_tag;
8048
8049 if (argc) {
8050 prompt_tag = argv[0];
8051 if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(prompt_tag))) {
8052 if (SCHEME_NP_CHAPERONEP(prompt_tag)
8053 && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(prompt_tag)))
8054 prompt_tag = SCHEME_CHAPERONE_VAL(prompt_tag);
8055 else
8056 scheme_wrong_contract("current-continuation-marks", "continuation-prompt-tag?",
8057 0, argc, argv);
8058 }
8059
8060 if (!SAME_OBJ(scheme_default_prompt_tag, prompt_tag)
8061 && !SAME_OBJ(scheme_root_prompt_tag, prompt_tag))
8062 if (!scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(prompt_tag))) {
8063 scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
8064 "current-continuation-marks: no corresponding prompt in the continuation\n"
8065 " prompt tag: %V",
8066 prompt_tag);
8067 }
8068 }
8069
8070 return scheme_current_continuation_marks(argc ? prompt_tag : NULL);
8071 }
8072
8073 static Scheme_Object *
cont_marks(int argc,Scheme_Object * argv[])8074 cont_marks(int argc, Scheme_Object *argv[])
8075 {
8076 Scheme_Object *prompt_tag;
8077
8078 if (SCHEME_TRUEP(argv[0])
8079 && !SCHEME_CONTP(argv[0]) && !SCHEME_ECONTP(argv[0]) && !SCHEME_THREADP(argv[0]))
8080 scheme_wrong_contract("continuation-marks", "(or/c continuation? thread? #f)", 0, argc, argv);
8081
8082 if (argc > 1) {
8083 if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[1]))) {
8084 if (SCHEME_NP_CHAPERONEP(argv[1])
8085 && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(argv[1])))
8086 prompt_tag = SCHEME_CHAPERONE_VAL(argv[1]);
8087 else {
8088 scheme_wrong_contract("continuation-marks", "continuation-prompt-tag?",
8089 1, argc, argv);
8090 return NULL;
8091 }
8092 } else
8093 prompt_tag = argv[1];
8094 } else
8095 prompt_tag = scheme_default_prompt_tag;
8096
8097 if (SCHEME_FALSEP(argv[0])) {
8098 return make_empty_marks();
8099 } else if (SCHEME_ECONTP(argv[0])) {
8100 if (!scheme_escape_continuation_ok(argv[0])) {
8101 scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
8102 "continuation-marks: escape continuation not in the current thread's continuation\n"
8103 " escape continuation: %V", argv[0]);
8104 return NULL;
8105 } else {
8106 Scheme_Meta_Continuation *mc;
8107 mc = scheme_get_meta_continuation(argv[0]);
8108
8109 return continuation_marks(scheme_current_thread, NULL, argv[0], mc, prompt_tag,
8110 "continuation-marks", 0, 1);
8111 }
8112 } else if (SCHEME_THREADP(argv[0])) {
8113 Scheme_Thread *t = (Scheme_Thread *)argv[0];
8114 Scheme_Object *m;
8115
8116 while (t->nestee) {
8117 t = t->nestee;
8118 }
8119
8120 if (SAME_OBJ(t, scheme_current_thread))
8121 return scheme_current_continuation_marks(prompt_tag);
8122
8123 while (t->return_marks_to) {
8124 scheme_thread_block(0.0);
8125 }
8126
8127 if (!(t->running & MZTHREAD_RUNNING)) {
8128 return make_empty_marks();
8129 } else {
8130 scheme_start_atomic(); /* just in case */
8131
8132 t->return_marks_to = scheme_current_thread;
8133 t->returned_marks = prompt_tag;
8134 scheme_swap_thread(t);
8135
8136 m = t->returned_marks;
8137 t->returned_marks = NULL;
8138
8139 scheme_end_atomic_no_swap();
8140
8141 if (!m)
8142 scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
8143 "%s: no corresponding prompt in the continuation\n"
8144 " tag: %V",
8145 "continuation-marks", prompt_tag);
8146
8147 return m;
8148 }
8149 } else {
8150 return continuation_marks(NULL, argv[0], NULL, NULL, prompt_tag,
8151 "continuation-marks", 0, 1);
8152 }
8153 }
8154
8155 static Scheme_Object *
cc_marks_p(int argc,Scheme_Object * argv[])8156 cc_marks_p(int argc, Scheme_Object *argv[])
8157 {
8158 if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_cont_mark_set_type))
8159 return scheme_false;
8160 else
8161 return scheme_true;
8162 }
8163
8164 static Scheme_Object *
extract_cc_marks(int argc,Scheme_Object * argv[])8165 extract_cc_marks(int argc, Scheme_Object *argv[])
8166 {
8167 Scheme_Cont_Mark_Chain *chain;
8168 Scheme_Object *first = scheme_null, *last = NULL, *key, *prompt_tag;
8169 Scheme_Object *v;
8170 Scheme_Object *pr;
8171 int is_chaperoned = 0;
8172
8173 if (SCHEME_TRUEP(argv[0])
8174 && !SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_cont_mark_set_type)) {
8175 scheme_wrong_contract("continuation-mark-set->list", "(or/c continuation-mark-set? #f)", 0, argc, argv);
8176 return NULL;
8177 }
8178 if (argc > 2) {
8179 if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[2]))) {
8180 if (SCHEME_NP_CHAPERONEP(argv[2])
8181 && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(argv[2])))
8182 prompt_tag = SCHEME_CHAPERONE_VAL(argv[2]);
8183 else {
8184 scheme_wrong_contract("continuation-mark-set->list", "continuation-prompt-tag?",
8185 2, argc, argv);
8186 return NULL;
8187 }
8188 } else
8189 prompt_tag = argv[2];
8190 } else
8191 prompt_tag = scheme_default_prompt_tag;
8192
8193 if (SCHEME_FALSEP(argv[0]))
8194 chain = current_mark_chain("continuation-mark-set->list", prompt_tag);
8195 else
8196 chain = ((Scheme_Cont_Mark_Set *)argv[0])->chain;
8197 key = argv[1];
8198
8199 if ((key == scheme_parameterization_key)
8200 || (key == scheme_break_enabled_key)
8201 || (key == scheme_exn_handler_key)) {
8202 scheme_signal_error("continuation-mark-set->list: secret key leaked!");
8203 return NULL;
8204 }
8205
8206 if (SCHEME_NP_CHAPERONEP(key)
8207 && SCHEME_CONTINUATION_MARK_KEYP(SCHEME_CHAPERONE_VAL(key))) {
8208 is_chaperoned = 1;
8209 key = SCHEME_CHAPERONE_VAL(key);
8210 }
8211
8212 prompt_tag = SCHEME_PTR_VAL(prompt_tag);
8213
8214 while (chain) {
8215 if (chain->key == key) {
8216 if (is_chaperoned)
8217 v = scheme_chaperone_do_continuation_mark("continuation-mark-set->list",
8218 1, argv[1], chain->val);
8219 else
8220 v = chain->val;
8221 pr = scheme_make_pair(v, scheme_null);
8222 if (last)
8223 SCHEME_CDR(last) = pr;
8224 else
8225 first = pr;
8226 last = pr;
8227 } else if (chain->key == prompt_tag)
8228 break;
8229
8230 chain = chain->next;
8231 }
8232
8233 return first;
8234 }
8235
8236 static Scheme_Object *
iterate_cc_markses(const char * who,Scheme_Object * prompt_tag,Scheme_Object * none,intptr_t len,Scheme_Object ** keys,Scheme_Cont_Mark_Chain ** _chain)8237 iterate_cc_markses(const char *who,
8238 Scheme_Object *prompt_tag, Scheme_Object *none,
8239 intptr_t len, Scheme_Object **keys,
8240 Scheme_Cont_Mark_Chain **_chain)
8241 {
8242 Scheme_Cont_Mark_Chain *chain = *_chain;
8243 intptr_t last_pos = -1, i;
8244 Scheme_Object *vals = NULL;
8245
8246 prompt_tag = SCHEME_PTR_VAL(prompt_tag);
8247
8248 while (chain) {
8249 if (vals && (last_pos != chain->pos)) {
8250 *_chain = chain;
8251 return vals;
8252 }
8253
8254 for (i = 0; i < len; i++) {
8255 int is_chaperoned = 0;
8256 Scheme_Object *orig_key, *val;
8257
8258 if (SCHEME_MARK_CHAIN_FLAG(chain) & 0x1)
8259 last_pos = -1;
8260 if (SCHEME_NP_CHAPERONEP(keys[i])
8261 && SCHEME_CONTINUATION_MARK_KEYP(SCHEME_CHAPERONE_VAL(keys[i]))) {
8262 is_chaperoned = 1;
8263 orig_key = keys[i];
8264 keys[i] = SCHEME_CHAPERONE_VAL(orig_key);
8265 } else
8266 orig_key = NULL;
8267 if (SAME_OBJ(chain->key, keys[i])) {
8268 intptr_t pos;
8269 pos = (intptr_t)chain->pos;
8270 if (!vals) {
8271 vals = scheme_make_vector(len, none);
8272 last_pos = pos;
8273 }
8274 if (is_chaperoned) {
8275 val = scheme_chaperone_do_continuation_mark(who,
8276 1, orig_key, chain->val);
8277 SCHEME_VEC_ELS(vals)[i] = val;
8278 } else
8279 SCHEME_VEC_ELS(vals)[i] = chain->val;
8280 }
8281 }
8282
8283 if (SAME_OBJ(chain->key, prompt_tag))
8284 break;
8285
8286 chain = chain->next;
8287 }
8288
8289 *_chain = NULL;
8290
8291 return vals;
8292 }
8293
iterate_step(void * data,int argc,Scheme_Object * argv[])8294 static Scheme_Object *iterate_step(void *data, int argc, Scheme_Object *argv[])
8295 {
8296 Scheme_Cont_Mark_Chain *chain = ((void **)data)[0];
8297 void **clos = ((void **)data)[1], **new_state;
8298 Scheme_Object *vals, *a[2];
8299 Scheme_Object *prompt_tag = ((Scheme_Object **)clos)[0];
8300 Scheme_Object **keys = ((Scheme_Object ***)clos)[1];
8301 intptr_t len = SCHEME_INT_VAL(((Scheme_Object **)clos)[2]);
8302 Scheme_Object *none = ((Scheme_Object **)clos)[3];
8303
8304 if (!chain) {
8305 a[0] = scheme_false;
8306 new_state = data;
8307 } else {
8308 vals = iterate_cc_markses("mark-list*-iterator", prompt_tag, none, len, keys, &chain);
8309 if (!vals)
8310 a[0] = scheme_false;
8311 else
8312 a[0] = vals;
8313 new_state = MALLOC_N(void*, 2);
8314 new_state[0] = chain;
8315 new_state[1] = clos;
8316 }
8317
8318 a[1] = scheme_make_closed_prim_w_arity(iterate_step, new_state, "mark-list*-iterator", 0, 0);
8319 return scheme_values(2, a);
8320 }
8321
8322 static Scheme_Object *
do_extract_cc_markses(const char * who,int argc,Scheme_Object * argv[],int iterator)8323 do_extract_cc_markses(const char *who, int argc, Scheme_Object *argv[], int iterator)
8324 {
8325 Scheme_Cont_Mark_Chain *chain;
8326 Scheme_Object *first = scheme_null, *last = NULL;
8327 Scheme_Object *pr, **keys, *vals, *none, *prompt_tag;
8328 intptr_t len, i;
8329
8330 if (SCHEME_TRUEP(argv[0])
8331 && !SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_cont_mark_set_type)) {
8332 scheme_wrong_contract(who, "(or/c continuation-mark-set? #f)", 0, argc, argv);
8333 return NULL;
8334 }
8335 len = scheme_proper_list_length(argv[1]);
8336 if (len < 0) {
8337 scheme_wrong_contract(who, "list?", 1, argc, argv);
8338 return NULL;
8339 }
8340 if (argc > 2)
8341 none = argv[2];
8342 else
8343 none = scheme_false;
8344 if (argc > 3) {
8345 if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[3]))) {
8346 if (SCHEME_NP_CHAPERONEP(argv[3])
8347 && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(argv[3])))
8348 prompt_tag = SCHEME_CHAPERONE_VAL(argv[3]);
8349 else {
8350 scheme_wrong_contract(who, "continuation-prompt-tag?",
8351 3, argc, argv);
8352 return NULL;
8353 }
8354 } else
8355 prompt_tag = argv[3];
8356 } else
8357 prompt_tag = scheme_default_prompt_tag;
8358
8359 keys = MALLOC_N(Scheme_Object *, len);
8360 for (pr = argv[1], i = 0; SCHEME_PAIRP(pr); pr = SCHEME_CDR(pr), i++) {
8361 keys[i] = SCHEME_CAR(pr);
8362 if ((keys[i] == scheme_parameterization_key)
8363 || (keys[i] == scheme_break_enabled_key)) {
8364 scheme_signal_error("%s: misuse of primitive key", who);
8365 return NULL;
8366 }
8367 }
8368
8369 if (SCHEME_FALSEP(argv[0]))
8370 chain = current_mark_chain(who, prompt_tag);
8371 else
8372 chain = ((Scheme_Cont_Mark_Set *)argv[0])->chain;
8373
8374 if (iterator) {
8375 void **clos, **state;
8376 clos = MALLOC_N(void*, 4);
8377 clos[0] = prompt_tag;
8378 clos[1] = keys;
8379 clos[2] = scheme_make_integer(len);
8380 clos[3] = none;
8381 state = MALLOC_N(void*, 2);
8382 state[0] = chain;
8383 state[1] = clos;
8384 return scheme_make_closed_prim_w_arity(iterate_step, state, "mark-list*-iterator", 0, 0);
8385 } else {
8386 while (chain) {
8387 vals = iterate_cc_markses(who, prompt_tag, none, len, keys, &chain);
8388 if (vals) {
8389 pr = scheme_make_pair(vals, scheme_null);
8390 if (last)
8391 SCHEME_CDR(last) = pr;
8392 else
8393 first = pr;
8394 last = pr;
8395 }
8396 }
8397
8398 return first;
8399 }
8400 }
8401
8402 static Scheme_Object *
extract_cc_markses(int argc,Scheme_Object * argv[])8403 extract_cc_markses(int argc, Scheme_Object *argv[])
8404 {
8405 return do_extract_cc_markses("continuation-mark-set->list*", argc, argv, 0);
8406 }
8407
8408 static Scheme_Object *
extract_cc_iterator(int argc,Scheme_Object * argv[])8409 extract_cc_iterator(int argc, Scheme_Object *argv[])
8410 {
8411 return do_extract_cc_markses("continuation-mark-set->iterator", argc, argv, 1);
8412 }
8413
8414 Scheme_Object *
scheme_get_stack_trace(Scheme_Object * mark_set)8415 scheme_get_stack_trace(Scheme_Object *mark_set)
8416 {
8417 Scheme_Object *l, *n, *m, *name, *loc;
8418 Scheme_Object *a[2];
8419
8420 l = ((Scheme_Cont_Mark_Set *)mark_set)->native_stack_trace;
8421
8422 if (!l) {
8423 a[0] = mark_set;
8424 a[1] = scheme_stack_dump_key;
8425
8426 l = extract_cc_marks(2, a);
8427 } else {
8428 /* Copy l: */
8429 Scheme_Object *first = scheme_null, *last = NULL;
8430 while (SCHEME_PAIRP(l)) {
8431 n = scheme_make_pair(SCHEME_CAR(l), scheme_null);
8432 if (last)
8433 SCHEME_CDR(last) = n;
8434 else
8435 first = n;
8436 last = n;
8437 l = SCHEME_CDR(l);
8438 }
8439 l = first;
8440 }
8441
8442 /* Filter out NULLs */
8443 while (SCHEME_PAIRP(l) && !SCHEME_CAR(l)) {
8444 l = SCHEME_CDR(l);
8445 }
8446 for (n = l; SCHEME_PAIRP(n); ) {
8447 m = SCHEME_CDR(n);
8448 if (SCHEME_NULLP(m))
8449 break;
8450 if (SCHEME_CAR(m)) {
8451 n = m;
8452 } else {
8453 SCHEME_CDR(n) = SCHEME_CDR(m);
8454 }
8455 }
8456
8457 /* Make srclocs */
8458 for (n = l; SCHEME_PAIRP(n); n = SCHEME_CDR(n)) {
8459 name = SCHEME_CAR(n);
8460 if (SCHEME_VECTORP(name)) {
8461 loc = scheme_make_location(SCHEME_VEC_ELS(name)[1],
8462 SCHEME_VEC_ELS(name)[2],
8463 SCHEME_VEC_ELS(name)[3],
8464 SCHEME_VEC_ELS(name)[4],
8465 SCHEME_VEC_ELS(name)[5]);
8466 if (SCHEME_TRUEP(SCHEME_VEC_ELS(name)[6]))
8467 name = scheme_make_pair(scheme_false, loc);
8468 else
8469 name = scheme_make_pair(SCHEME_VEC_ELS(name)[0], loc);
8470 } else if (SCHEME_PAIRP(name) && SAME_OBJ(SCHEME_CDR(name), scheme_true)) {
8471 /* a pair with #t we're running a module body */
8472 const char *what;
8473
8474 what = "[running body]";
8475
8476 name = SCHEME_CAR(name);
8477 loc = scheme_make_location(name, scheme_false, scheme_false, scheme_false, scheme_false);
8478
8479 name = scheme_intern_symbol(what);
8480 name = scheme_make_pair(name, loc);
8481 } else {
8482 name = scheme_make_pair(name, scheme_false);
8483 }
8484 SCHEME_CAR(n) = name;
8485 }
8486
8487 return l;
8488 }
8489
8490 static Scheme_Object *
extract_cc_proc_marks(int argc,Scheme_Object * argv[])8491 extract_cc_proc_marks(int argc, Scheme_Object *argv[])
8492 {
8493 if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_cont_mark_set_type)) {
8494 scheme_wrong_contract("continuation-mark-set->context", "continuation-mark-set?", 0, argc, argv);
8495 return NULL;
8496 }
8497
8498 return scheme_get_stack_trace(argv[0]);
8499 }
8500
default_mark_value(Scheme_Object * key)8501 XFORM_NONGCING static Scheme_Object *default_mark_value(Scheme_Object *key)
8502 {
8503 if (key == scheme_parameterization_key)
8504 return (Scheme_Object *)scheme_current_thread->init_config;
8505 else if (key == scheme_break_enabled_key)
8506 return scheme_current_thread->init_break_cell;
8507
8508 return NULL;
8509 }
8510
8511 static Scheme_Object *
scheme_extract_one_cc_mark_with_meta(Scheme_Object * mark_set,Scheme_Object * key_arg,Scheme_Object * prompt_tag,Scheme_Meta_Continuation ** _meta,MZ_MARK_POS_TYPE * _vpos)8512 scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set, Scheme_Object *key_arg,
8513 Scheme_Object *prompt_tag, Scheme_Meta_Continuation **_meta,
8514 MZ_MARK_POS_TYPE *_vpos)
8515 {
8516 Scheme_Object *key = key_arg;
8517
8518 if (prompt_tag && SAME_OBJ(prompt_tag, SCHEME_PTR_VAL(scheme_root_prompt_tag)))
8519 prompt_tag = NULL;
8520
8521 if (SCHEME_NP_CHAPERONEP(key)
8522 && SCHEME_CONTINUATION_MARK_KEYP(SCHEME_CHAPERONE_VAL(key))) {
8523 key = SCHEME_CHAPERONE_VAL(key);
8524 }
8525
8526 if (mark_set) {
8527 Scheme_Cont_Mark_Chain *chain;
8528 chain = ((Scheme_Cont_Mark_Set *)mark_set)->chain;
8529 while (chain) {
8530 if (chain->key == key)
8531 if (key_arg != key)
8532 return scheme_chaperone_do_continuation_mark("continuation-mark-set-first",
8533 1, key_arg, chain->val);
8534 else
8535 return chain->val;
8536 else if (SAME_OBJ(chain->key, prompt_tag))
8537 break;
8538 else
8539 chain = chain->next;
8540 }
8541 } else {
8542 intptr_t findpos, bottom, startpos;
8543 intptr_t pos;
8544 Scheme_Object *val = NULL;
8545 MZ_MARK_POS_TYPE vpos = 0;
8546 Scheme_Object *cache;
8547 Scheme_Meta_Continuation *mc = NULL;
8548 Scheme_Cont_Mark *seg;
8549 Scheme_Thread *p = scheme_current_thread;
8550
8551 do {
8552 if (mc) {
8553 startpos = mc->cont_mark_total;
8554 bottom = 0;
8555 } else {
8556 startpos = (intptr_t)MZ_CONT_MARK_STACK;
8557 bottom = p->cont_mark_stack_bottom;
8558 }
8559
8560 findpos = startpos;
8561
8562 /* Search mark stack, checking caches along the way: */
8563 while (findpos-- > bottom) {
8564 if (mc) {
8565 seg = mc->cont_mark_stack_copied;
8566 pos = findpos;
8567 } else {
8568 seg = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE];
8569 pos = findpos & SCHEME_MARK_SEGMENT_MASK;
8570 }
8571
8572 if (SAME_OBJ(seg[pos].key, key)) {
8573 val = seg[pos].val;
8574 vpos = seg[pos].pos;
8575 break;
8576 } else if (SAME_OBJ(seg[pos].key, prompt_tag)) {
8577 break;
8578 } else {
8579 cache = seg[pos].cache;
8580 if (cache && SCHEME_HASHTP(cache))
8581 cache = scheme_eq_hash_get((Scheme_Hash_Table *)cache,
8582 prompt_tag ? prompt_tag : scheme_false);
8583 else if (prompt_tag)
8584 cache = NULL;
8585 if (cache && SCHEME_VECTORP(cache)) {
8586 /* If slot 1 has a key, this cache has just one key--value
8587 pair. Otherwise, slot 2 is a hash table. */
8588 if (SCHEME_VEC_ELS(cache)[1]) {
8589 if (SAME_OBJ(SCHEME_VEC_ELS(cache)[1], key)) {
8590 val = SCHEME_VEC_ELS(cache)[2];
8591 vpos = (MZ_MARK_POS_TYPE)SCHEME_VEC_ELS(cache)[3];
8592 break;
8593 }
8594 } else {
8595 Scheme_Hash_Table *ht;
8596 ht = (Scheme_Hash_Table *)SCHEME_VEC_ELS(cache)[2];
8597 val = scheme_eq_hash_get(ht, key);
8598 if (val) {
8599 vpos = (MZ_MARK_POS_TYPE)SCHEME_CDR(val);
8600 val = SCHEME_CAR(val);
8601 break;
8602 }
8603 }
8604 }
8605 }
8606 }
8607
8608 if (key_arg != key && val != NULL)
8609 val = scheme_chaperone_do_continuation_mark("continuation-mark-set-first", 1, key_arg, val);
8610
8611 pos = startpos - findpos;
8612 if (pos > MARK_CACHE_THRESHOLD) {
8613 pos >>= 1;
8614 findpos = findpos + pos;
8615 if (mc) {
8616 seg = mc->cont_mark_stack_copied;
8617 pos = findpos;
8618 } else {
8619 seg = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE];
8620 pos = findpos & SCHEME_MARK_SEGMENT_MASK;
8621 }
8622
8623 /* See continuation_marks() for information on what
8624 cache can be: */
8625 cache = seg[pos].cache;
8626 {
8627 Scheme_Hash_Table *cht;
8628 if (cache && SCHEME_HASHTP(cache)) {
8629 cht = (Scheme_Hash_Table *)cache;
8630 cache = scheme_eq_hash_get(cht, prompt_tag ? prompt_tag : scheme_false);
8631 } else if (prompt_tag) {
8632 cht = scheme_make_hash_table(SCHEME_hash_ptr);
8633 if (cache) {
8634 if (SCHEME_VECTORP(cache)) {
8635 Scheme_Object *vec;
8636 if (SCHEME_VEC_ELS(cache)[0])
8637 scheme_hash_set(cht, scheme_default_prompt_tag, SCHEME_VEC_ELS(cache)[0]);
8638 /* Don't try to re-use cache just for the null key */
8639 vec = scheme_make_vector(4, NULL);
8640 SCHEME_VEC_ELS(vec)[1] = SCHEME_VEC_ELS(cache)[1];
8641 SCHEME_VEC_ELS(vec)[2] = SCHEME_VEC_ELS(cache)[2];
8642 SCHEME_VEC_ELS(vec)[3] = SCHEME_VEC_ELS(cache)[3];
8643 scheme_hash_set(cht, scheme_false, vec);
8644 } else {
8645 scheme_hash_set(cht, scheme_default_prompt_tag, cache);
8646 }
8647 cache = NULL;
8648 }
8649 seg[pos].cache = (Scheme_Object *)cht;
8650 } else
8651 cht = NULL;
8652
8653 if (!cache || !SCHEME_VECTORP(cache)) {
8654 /* No cache so far, so map one key */
8655 cache = scheme_make_vector(4, NULL);
8656 SCHEME_VEC_ELS(cache)[1] = key;
8657 SCHEME_VEC_ELS(cache)[2] = val;
8658 SCHEME_VEC_ELS(cache)[3] = (Scheme_Object *)vpos;
8659 if (cht) {
8660 scheme_hash_set(cht, prompt_tag ? prompt_tag : scheme_false, cache);
8661 } else {
8662 if (seg[pos].cache && !SCHEME_FALSEP(seg[pos].cache))
8663 SCHEME_VEC_ELS(cache)[0] = seg[pos].cache;
8664 seg[pos].cache = cache;
8665 }
8666 } else {
8667 if (SCHEME_VEC_ELS(cache)[1]) {
8668 /* More than one cached key, now; create hash table */
8669 Scheme_Hash_Table *ht;
8670 ht = scheme_make_hash_table(SCHEME_hash_ptr);
8671 scheme_hash_set(ht, key, scheme_make_raw_pair(val, (Scheme_Object *)vpos));
8672 scheme_hash_set(ht, SCHEME_VEC_ELS(cache)[1], scheme_make_raw_pair(SCHEME_VEC_ELS(cache)[2],
8673 SCHEME_VEC_ELS(cache)[3]));
8674 SCHEME_VEC_ELS(cache)[1] = NULL;
8675 SCHEME_VEC_ELS(cache)[2] = (Scheme_Object *)ht;
8676 } else {
8677 /* Already have a hash table */
8678 Scheme_Hash_Table *ht;
8679 ht = (Scheme_Hash_Table *)SCHEME_VEC_ELS(cache)[2];
8680 scheme_hash_set(ht, key, scheme_make_raw_pair(val, (Scheme_Object *)vpos));
8681 }
8682 }
8683 }
8684 }
8685
8686 if (val) {
8687 if (_meta)
8688 *_meta = mc;
8689 if (_vpos)
8690 *_vpos = vpos;
8691 return val;
8692 }
8693
8694 if (mc) {
8695 mc = mc->next;
8696 } else {
8697 mc = p->meta_continuation;
8698 }
8699 } while (mc);
8700 }
8701
8702 return default_mark_value(key);
8703 }
8704
8705 XFORM_NONGCING static Scheme_Object *
extract_one_cc_mark_fast(Scheme_Object * key,int * _conclusive)8706 extract_one_cc_mark_fast(Scheme_Object *key, int *_conclusive)
8707 /* A non-GCing fast path for scheme_extract_one_cc_mark_with_meta()
8708 where there are no complications. */
8709 {
8710 intptr_t findpos, bottom, startpos;
8711 intptr_t pos;
8712 Scheme_Object *val = NULL;
8713 Scheme_Object *cache;
8714 Scheme_Cont_Mark *seg;
8715 Scheme_Thread *p = scheme_current_thread;
8716 Scheme_Meta_Continuation *mc = NULL;
8717
8718 do {
8719 if (mc) {
8720 startpos = mc->cont_mark_total;
8721 bottom = 0;
8722 } else {
8723 startpos = (intptr_t)MZ_CONT_MARK_STACK;
8724 bottom = p->cont_mark_stack_bottom;
8725 }
8726
8727 findpos = startpos;
8728
8729 /* Search mark stack, checking caches along the way: */
8730 while (findpos-- > bottom) {
8731 if ((startpos - findpos) > MARK_CACHE_THRESHOLD) {
8732 /* Use full search to trigger caching */
8733 return NULL;
8734 }
8735
8736 if (mc) {
8737 seg = mc->cont_mark_stack_copied;
8738 pos = findpos;
8739 } else {
8740 seg = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE];
8741 pos = findpos & SCHEME_MARK_SEGMENT_MASK;
8742 }
8743
8744 if (SAME_OBJ(seg[pos].key, key)) {
8745 *_conclusive = 1;
8746 return seg[pos].val;
8747 } else {
8748 cache = seg[pos].cache;
8749 if (cache && SCHEME_HASHTP(cache))
8750 cache = scheme_eq_hash_get((Scheme_Hash_Table *)cache, scheme_false);
8751 if (cache && SCHEME_VECTORP(cache)) {
8752 /* If slot 1 has a key, this cache has just one key--value
8753 pair. Otherwise, slot 2 is a hash table. */
8754 if (SCHEME_VEC_ELS(cache)[1]) {
8755 if (SAME_OBJ(SCHEME_VEC_ELS(cache)[1], key)) {
8756 val = SCHEME_VEC_ELS(cache)[2];
8757 if (val) {
8758 *_conclusive = 1;
8759 return val;
8760 } else
8761 break; /* cached absence of a value */
8762 }
8763 } else {
8764 Scheme_Hash_Table *ht;
8765 ht = (Scheme_Hash_Table *)SCHEME_VEC_ELS(cache)[2];
8766 val = scheme_eq_hash_get(ht, key);
8767 if (val) {
8768 val = SCHEME_CAR(val);
8769 if (val) {
8770 *_conclusive = 1;
8771 return val;
8772 } else
8773 break; /* cached absence of a value */
8774 }
8775 }
8776 }
8777 }
8778 }
8779
8780 if (mc)
8781 mc = mc->next;
8782 else
8783 mc = p->meta_continuation;
8784 } while (mc);
8785
8786 /* Since we searched the metacontinuation chain,
8787 the absence of a value is conclusive */
8788 *_conclusive = 1;
8789 return default_mark_value(key);
8790 }
8791
get_set_cont_mark_by_pos(Scheme_Object * key,Scheme_Thread * p,Scheme_Meta_Continuation * mc,MZ_MARK_POS_TYPE mpos,Scheme_Object * val)8792 static Scheme_Object *get_set_cont_mark_by_pos(Scheme_Object *key,
8793 Scheme_Thread *p,
8794 Scheme_Meta_Continuation *mc,
8795 MZ_MARK_POS_TYPE mpos,
8796 Scheme_Object *val)
8797 {
8798 intptr_t findpos, bottom, startpos;
8799 intptr_t pos;
8800 int down_delta = 0;
8801 Scheme_Cont_Mark *seg;
8802
8803 if (mc) {
8804 startpos = mc->cont_mark_total;
8805 bottom = 0;
8806 } else {
8807 startpos = (intptr_t)MZ_CONT_MARK_STACK;
8808 bottom = p->cont_mark_stack_bottom;
8809 }
8810
8811 /* binary search: */
8812 while (bottom < startpos) {
8813 findpos = ((bottom + startpos) / 2) - down_delta;
8814
8815 if (mc) {
8816 seg = mc->cont_mark_stack_copied;
8817 pos = findpos;
8818 } else {
8819 seg = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE];
8820 pos = findpos & SCHEME_MARK_SEGMENT_MASK;
8821 }
8822
8823 if (seg[pos].pos == mpos) {
8824 if (SAME_OBJ(seg[pos].key, key)) {
8825 if (!val)
8826 return seg[pos].val;
8827
8828 if (mc && mc->cm_shared)
8829 seg = copy_cm_shared_on_write(mc);
8830
8831 seg[pos].val = val;
8832
8833 return scheme_void;
8834 } else if (findpos > bottom) {
8835 down_delta++;
8836 } else {
8837 bottom = (findpos + down_delta) + 1;
8838 down_delta = 0;
8839 }
8840 } else if (seg[pos].pos < mpos) {
8841 bottom = findpos + 1;
8842 } else {
8843 startpos = findpos;
8844 }
8845 }
8846
8847 scheme_signal_error("get_set_cont_mark_by_pos: key not found");
8848 return NULL;
8849 }
8850
8851 Scheme_Object *
scheme_extract_one_cc_mark(Scheme_Object * mark_set,Scheme_Object * key)8852 scheme_extract_one_cc_mark(Scheme_Object *mark_set, Scheme_Object *key)
8853 {
8854 Scheme_Object *v;
8855
8856 if (!mark_set) {
8857 int conclusive = 0;
8858 v = extract_one_cc_mark_fast(key, &conclusive);
8859 if (conclusive) return v;
8860 }
8861
8862 return scheme_extract_one_cc_mark_with_meta(mark_set, key, NULL, NULL, NULL);
8863 }
8864
8865 Scheme_Object *
scheme_extract_one_cc_mark_to_tag(Scheme_Object * mark_set,Scheme_Object * key,Scheme_Object * prompt_tag)8866 scheme_extract_one_cc_mark_to_tag(Scheme_Object *mark_set, Scheme_Object *key,
8867 Scheme_Object *prompt_tag)
8868 {
8869 return scheme_extract_one_cc_mark_with_meta(mark_set, key, prompt_tag, NULL, NULL);
8870 }
8871
8872 static Scheme_Object *
extract_one_cc_mark(int argc,Scheme_Object * argv[])8873 extract_one_cc_mark(int argc, Scheme_Object *argv[])
8874 {
8875 Scheme_Object *r;
8876 Scheme_Object *prompt_tag;
8877
8878 if (SCHEME_TRUEP(argv[0])
8879 && !SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_cont_mark_set_type))
8880 scheme_wrong_contract("continuation-mark-set-first", "(or/c continuation-mark-set? #f)", 0, argc, argv);
8881
8882 if ((argv[1] == scheme_parameterization_key)
8883 || (argv[1] == scheme_break_enabled_key)) {
8884 /* Minor hack: these keys are used in the startup linklet to access
8885 parameterizations, and we want that access to go through
8886 prompts. If they keys somehow leaked, it's ok, because that
8887 doesn't expose anything that isn't already exposed by functions
8888 like `current-parameterization'. */
8889 prompt_tag = NULL;
8890 } else
8891 prompt_tag = scheme_default_prompt_tag;
8892
8893 if (argc > 3) {
8894 if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[3]))) {
8895 if (SCHEME_NP_CHAPERONEP(argv[3])
8896 && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(argv[3])))
8897 prompt_tag = SCHEME_CHAPERONE_VAL(argv[3]);
8898 else
8899 scheme_wrong_contract("continuation-mark-set-first", "continuation-prompt-tag?",
8900 3, argc, argv);
8901 } else
8902 prompt_tag = argv[3];
8903
8904 if (!SAME_OBJ(scheme_default_prompt_tag, prompt_tag)
8905 && !SAME_OBJ(scheme_root_prompt_tag, prompt_tag)) {
8906 if (SCHEME_FALSEP(argv[0])) {
8907 if (!scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(prompt_tag))) {
8908 scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
8909 "continuation-mark-set-first: no corresponding prompt in the current continuation\n"
8910 " tag: %V",
8911 prompt_tag);
8912 }
8913 }
8914 }
8915 }
8916
8917 r = scheme_extract_one_cc_mark_to_tag(SCHEME_TRUEP(argv[0]) ? argv[0] : NULL, argv[1],
8918 prompt_tag ? SCHEME_PTR_VAL(prompt_tag) : NULL);
8919 if (!r) {
8920 if (argc > 2)
8921 r = argv[2];
8922 else
8923 r = scheme_false;
8924 }
8925
8926 return r;
8927 }
8928
scheme_is_cm_deeper(Scheme_Meta_Continuation * m1,MZ_MARK_POS_TYPE p1,Scheme_Meta_Continuation * m2,MZ_MARK_POS_TYPE p2)8929 int scheme_is_cm_deeper(Scheme_Meta_Continuation *m1, MZ_MARK_POS_TYPE p1,
8930 Scheme_Meta_Continuation *m2, MZ_MARK_POS_TYPE p2)
8931 {
8932 if (m1 != m2) {
8933 if (!m1)
8934 return 0;
8935 if (!m2)
8936 return 1;
8937 return (m1->depth < m2->depth);
8938 }
8939 return p1 < p2;
8940 }
8941
continuation_prompt_available(int argc,Scheme_Object * argv[])8942 static Scheme_Object *continuation_prompt_available(int argc, Scheme_Object *argv[])
8943 {
8944 Scheme_Object *prompt_tag;
8945
8946 prompt_tag = argv[0];
8947 if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(prompt_tag))) {
8948 if (SCHEME_NP_CHAPERONEP(prompt_tag)
8949 && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(prompt_tag)))
8950 prompt_tag = SCHEME_CHAPERONE_VAL(prompt_tag);
8951 else
8952 scheme_wrong_contract("continuation-prompt-available?", "continuation-prompt-tag?",
8953 0, argc, argv);
8954 }
8955
8956 if (argc > 1) {
8957 if (SCHEME_ECONTP(argv[1])) {
8958 if (!scheme_escape_continuation_ok(argv[1])) {
8959 scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
8960 "continuation-prompt-available?: escape continuation not in the current thread's continuation\n"
8961 " escape continuation: %V",
8962 argv[1]);
8963 return NULL;
8964 } else {
8965 Scheme_Meta_Continuation *mc;
8966
8967 if (SAME_OBJ(scheme_default_prompt_tag, prompt_tag)
8968 || SAME_OBJ(scheme_root_prompt_tag, prompt_tag))
8969 return scheme_true;
8970
8971 mc = scheme_get_meta_continuation(argv[1]);
8972
8973 if (continuation_marks(scheme_current_thread, NULL, argv[1], mc, prompt_tag,
8974 NULL, 0, 0))
8975 return scheme_true;
8976 }
8977 } else if (SCHEME_CONTP(argv[1])) {
8978 if (continuation_marks(NULL, argv[1], NULL, NULL, prompt_tag, NULL, 0, 0))
8979 return scheme_true;
8980 } else {
8981 scheme_wrong_contract("continuation-prompt-available?", "continuation?",
8982 1, argc, argv);
8983 }
8984 } else {
8985 if (SAME_OBJ(scheme_default_prompt_tag, prompt_tag)
8986 || SAME_OBJ(scheme_root_prompt_tag, prompt_tag))
8987 return scheme_true;
8988
8989 if (scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(prompt_tag)))
8990 return scheme_true;
8991 }
8992
8993 return scheme_false;
8994 }
8995
8996 /*========================================================================*/
8997 /* lightweight continuations */
8998 /*========================================================================*/
8999
9000 /* A lightweight continuation is one that contains only frames from
9001 JIT-generated code. The code here manages capture and restore for
9002 the runstack and mark stack, while the rest is in the JIT. */
9003
9004 #ifdef MZ_USE_JIT
9005
9006 struct Scheme_Lightweight_Continuation {
9007 MZTAG_IF_REQUIRED /* scheme_rt_lightweight_cont */
9008 Scheme_Current_LWC *saved_lwc;
9009 void *stack_slice;
9010 Scheme_Object **runstack_slice;
9011 Scheme_Cont_Mark *cont_mark_stack_slice;
9012 void *stored1, *stored2;
9013 };
9014
scheme_init_thread_lwc(void)9015 void scheme_init_thread_lwc(void) XFORM_SKIP_PROC
9016 {
9017 scheme_current_lwc = (Scheme_Current_LWC *)malloc(sizeof(Scheme_Current_LWC));
9018 }
9019
scheme_fill_lwc_start(void)9020 void scheme_fill_lwc_start(void) XFORM_SKIP_PROC
9021 {
9022 scheme_current_lwc->runstack_start = MZ_RUNSTACK;
9023 scheme_current_lwc->cont_mark_stack_start = MZ_CONT_MARK_STACK;
9024 scheme_current_lwc->cont_mark_pos_start = MZ_CONT_MARK_POS;
9025 }
9026
scheme_fill_lwc_end(void)9027 void scheme_fill_lwc_end(void) XFORM_SKIP_PROC
9028 {
9029 scheme_current_lwc->runstack_end = MZ_RUNSTACK;
9030 scheme_current_lwc->cont_mark_stack_end = MZ_CONT_MARK_STACK;
9031 scheme_current_lwc->cont_mark_pos_end = MZ_CONT_MARK_POS;
9032 scheme_fill_stack_lwc_end();
9033 }
9034
scheme_clear_lwc(void)9035 void scheme_clear_lwc(void) XFORM_SKIP_PROC
9036 {
9037 }
9038
scheme_capture_lightweight_continuation(Scheme_Thread * p,Scheme_Current_LWC * p_lwc,void ** storage)9039 Scheme_Lightweight_Continuation *scheme_capture_lightweight_continuation(Scheme_Thread *p,
9040 Scheme_Current_LWC *p_lwc,
9041 void **storage)
9042 XFORM_SKIP_PROC
9043 /* This function explicitly cooperates with the GC by storing the
9044 pointers it needs to save across a collection in `storage'. Also,
9045 if allocation fails, it can abort and return NULL. The combination
9046 allows it to work in a thread for running futures (where allocation
9047 and GC in general ae disallowed). */
9048 {
9049 intptr_t len, i, j, pos;
9050 Scheme_Object **runstack_slice;
9051 Scheme_Cont_Mark *cont_mark_stack_slice;
9052 Scheme_Current_LWC *lwc;
9053 Scheme_Cont_Mark *seg;
9054 Scheme_Lightweight_Continuation *lw;
9055 void *stack;
9056
9057 storage[1] = p;
9058
9059 lw = MALLOC_ONE_RT(Scheme_Lightweight_Continuation);
9060 if (!lw) return NULL;
9061 #ifdef MZTAG_REQUIRED
9062 lw->type = scheme_rt_lightweight_cont;
9063 #endif
9064
9065 storage[0] = lw;
9066
9067 lwc = (Scheme_Current_LWC *)scheme_malloc_atomic(sizeof(Scheme_Current_LWC));
9068 if (!lwc) return NULL;
9069
9070 memcpy(lwc, p_lwc, sizeof(Scheme_Current_LWC));
9071
9072 lw = (Scheme_Lightweight_Continuation *)storage[0];
9073 lw->saved_lwc = lwc;
9074
9075 stack = scheme_save_lightweight_continuation_stack(p_lwc);
9076 if (!stack) return NULL;
9077
9078 lw = (Scheme_Lightweight_Continuation *)storage[0];
9079 lw->stack_slice = stack;
9080 lwc = lw->saved_lwc;
9081
9082 len = lwc->runstack_start - lwc->runstack_end;
9083 runstack_slice = MALLOC_N(Scheme_Object*, len);
9084 if (!runstack_slice) return NULL;
9085
9086 lw = (Scheme_Lightweight_Continuation *)storage[0];
9087 lwc = lw->saved_lwc;
9088 lw->runstack_slice = runstack_slice;
9089 memcpy(runstack_slice, lw->saved_lwc->runstack_end, len * sizeof(Scheme_Object *));
9090
9091 /* The runstack may contain pointers to itself, but they are just
9092 cleared slots where a register containing the runstack pointer
9093 was handy; zero out such slots to avoid retaining a runstack
9094 unnecessarily: */
9095 for (i = 0; i < len; i++) {
9096 if (((uintptr_t)runstack_slice[i] >= (uintptr_t)lwc->runstack_end)
9097 && ((uintptr_t)runstack_slice[i] <= (uintptr_t)lwc->runstack_start))
9098 runstack_slice[i] = NULL;
9099 }
9100
9101 len = lwc->cont_mark_stack_end - lwc->cont_mark_stack_start;
9102
9103 if (len) {
9104 cont_mark_stack_slice = MALLOC_N(Scheme_Cont_Mark, len);
9105 if (!cont_mark_stack_slice) return NULL;
9106 lw = (Scheme_Lightweight_Continuation *)storage[0];
9107 } else
9108 cont_mark_stack_slice = NULL;
9109
9110 lw->cont_mark_stack_slice = cont_mark_stack_slice;
9111
9112 lwc = lw->saved_lwc;
9113 p = (Scheme_Thread *)storage[1];
9114
9115 for (j = 0; j < len; j++) {
9116 i = j + lwc->cont_mark_stack_start;
9117
9118 seg = p->cont_mark_stack_segments[i >> SCHEME_LOG_MARK_SEGMENT_SIZE];
9119 pos = i & SCHEME_MARK_SEGMENT_MASK;
9120
9121 memcpy(cont_mark_stack_slice + j, seg + pos, sizeof(Scheme_Cont_Mark));
9122 }
9123
9124 return lw;
9125 }
9126
scheme_adjust_runstack_argument(Scheme_Lightweight_Continuation * lw,Scheme_Object ** arg)9127 Scheme_Object **scheme_adjust_runstack_argument(Scheme_Lightweight_Continuation *lw,
9128 Scheme_Object **arg)
9129 XFORM_SKIP_PROC
9130 {
9131 if (arg == lw->saved_lwc->runstack_end)
9132 return lw->runstack_slice;
9133 else
9134 return arg;
9135 }
9136
apply_lwc_k()9137 static void *apply_lwc_k()
9138 {
9139 Scheme_Thread *p = scheme_current_thread;
9140 Scheme_Lightweight_Continuation *lw = (Scheme_Lightweight_Continuation *)p->ku.k.p1;
9141 Scheme_Object *result = (Scheme_Object *)p->ku.k.p2;
9142
9143 p->ku.k.p1 = NULL;
9144 p->ku.k.p2 = NULL;
9145
9146 return scheme_apply_lightweight_continuation(lw, result, p->ku.k.i1, p->ku.k.i2);
9147 }
9148
9149 static Scheme_Object *can_apply_lwc_k(void);
9150
can_apply_lightweight_continuation(Scheme_Lightweight_Continuation * lw,int did_overflow)9151 static int can_apply_lightweight_continuation(Scheme_Lightweight_Continuation *lw, int did_overflow)
9152 {
9153 #ifdef DO_STACK_CHECK
9154 /* enough room on C stack? */
9155 uintptr_t size;
9156 size = (uintptr_t)lw->saved_lwc->stack_start - (uintptr_t)lw->saved_lwc->stack_end;
9157
9158 {
9159 # define SCHEME_PLUS_STACK_DELTA(x) ((x) - size)
9160 # include "mzstkchk.h"
9161 {
9162 if (did_overflow)
9163 return 0;
9164 else {
9165 scheme_current_thread->ku.k.p1 = lw;
9166 if (SCHEME_TRUEP(scheme_handle_stack_overflow(can_apply_lwc_k)))
9167 return 2;
9168 else
9169 return 0;
9170 }
9171 }
9172 }
9173
9174 return 1;
9175 #else
9176 return 0;
9177 #endif
9178 }
9179
scheme_can_apply_lightweight_continuation(Scheme_Lightweight_Continuation * lw,int check_overflow)9180 int scheme_can_apply_lightweight_continuation(Scheme_Lightweight_Continuation *lw, int check_overflow)
9181 /* result value 2 => need to handle stack overflow to have enough room */
9182 {
9183 if (check_overflow)
9184 return can_apply_lightweight_continuation(lw, 0);
9185 else
9186 /* assume that we can apply the continuation, though
9187 overflow handling may be needed (i.e., assume that the runtime
9188 thread's stack size is > than a future thread's stack) */
9189 return 1;
9190 }
9191
can_apply_lwc_k(void)9192 static Scheme_Object *can_apply_lwc_k(void)
9193 {
9194 Scheme_Thread *p = scheme_current_thread;
9195 Scheme_Lightweight_Continuation *lwc = (Scheme_Lightweight_Continuation *)p->ku.k.p1;
9196
9197 p->ku.k.p1 = NULL;
9198
9199 if (can_apply_lightweight_continuation(lwc, 1))
9200 return scheme_true;
9201 else
9202 return scheme_false;
9203 }
9204
scheme_apply_lightweight_continuation(Scheme_Lightweight_Continuation * lw,Scheme_Object * result,int result_is_rs_argv,intptr_t min_stacksize)9205 Scheme_Object *scheme_apply_lightweight_continuation(Scheme_Lightweight_Continuation *lw,
9206 Scheme_Object *result,
9207 int result_is_rs_argv,
9208 intptr_t min_stacksize)
9209 XFORM_SKIP_PROC
9210 {
9211 intptr_t len, cm_delta, i, cm;
9212 Scheme_Object **rs;
9213
9214 len = lw->saved_lwc->runstack_start - lw->saved_lwc->runstack_end;
9215
9216 if (!scheme_check_runstack(len)
9217 /* besides making sure that the save slice fits, we need to
9218 make sure that any advance check on available from the old thread
9219 still applies in the new thread */
9220 || ((MZ_RUNSTACK - MZ_RUNSTACK_START) < min_stacksize)) {
9221 /* This will not happen when restoring a future-thread-captured
9222 continuation in a future thread. */
9223 scheme_current_thread->ku.k.p1 = lw;
9224 scheme_current_thread->ku.k.p2 = result;
9225 scheme_current_thread->ku.k.i1 = result_is_rs_argv;
9226 scheme_current_thread->ku.k.i2 = min_stacksize;
9227 if (len < min_stacksize)
9228 len = min_stacksize;
9229 return (Scheme_Object *)scheme_enlarge_runstack(len, apply_lwc_k);
9230 }
9231
9232 /* application of a lightweight continuation forms a lightweight continuation: */
9233 scheme_current_lwc->runstack_start = MZ_RUNSTACK;
9234 scheme_current_lwc->cont_mark_stack_start = MZ_CONT_MARK_STACK;
9235 scheme_current_lwc->cont_mark_pos_start = MZ_CONT_MARK_POS + 2;
9236
9237 #ifdef MZ_USE_FUTURES
9238 jit_future_storage[3] = result;
9239 #endif
9240 lw = scheme_restore_lightweight_continuation_marks(lw); /* can trigger GC */
9241 #ifdef MZ_USE_FUTURES
9242 result = (Scheme_Object *)jit_future_storage[3];
9243 #endif
9244
9245 cm_delta = (intptr_t)MZ_CONT_MARK_STACK - (intptr_t)lw->saved_lwc->cont_mark_stack_end;
9246
9247 rs = MZ_RUNSTACK - len;
9248 MZ_RUNSTACK = rs;
9249
9250 memcpy(rs, lw->runstack_slice, len * sizeof(Scheme_Object*));
9251
9252 /* If SCHEME_EVAL_WAITING appears in the runstack slice, it
9253 indicates that a cm position follows: */
9254 for (i = 0; i < len; i++) {
9255 if (rs[i] == SCHEME_EVAL_WAITING) {
9256 cm = SCHEME_INT_VAL(rs[i+1]);
9257 cm += cm_delta;
9258 rs[i+1] = scheme_make_integer(cm);
9259 }
9260 }
9261
9262 if (result_is_rs_argv)
9263 result = (Scheme_Object *)(rs + 2);
9264
9265 return scheme_apply_lightweight_continuation_stack(lw->saved_lwc, lw->stack_slice, result);
9266 }
9267
scheme_restore_lightweight_continuation_marks(Scheme_Lightweight_Continuation * lw)9268 Scheme_Lightweight_Continuation *scheme_restore_lightweight_continuation_marks(Scheme_Lightweight_Continuation *lw)
9269 XFORM_SKIP_PROC
9270 /* Called by any thread, but this function can trigger a GC in the runtime thread */
9271 {
9272 intptr_t cm_len, i, cm_pos_delta;
9273 Scheme_Cont_Mark *seg;
9274
9275 cm_len = lw->saved_lwc->cont_mark_stack_end - lw->saved_lwc->cont_mark_stack_start;
9276 cm_pos_delta = MZ_CONT_MARK_POS + 2 - lw->saved_lwc->cont_mark_pos_start;
9277
9278 if (cm_len) {
9279 /* install captured continuation marks, adjusting the pos
9280 to match the new context: */
9281 seg = lw->cont_mark_stack_slice;
9282 for (i = 0; i < cm_len; i++) {
9283 MZ_CONT_MARK_POS = seg[i].pos + cm_pos_delta;
9284 #ifdef MZ_USE_FUTURES
9285 jit_future_storage[2] = lw;
9286 #endif
9287 scheme_set_cont_mark(seg[i].key, seg[i].val); /* can trigger a GC */
9288 #ifdef MZ_USE_FUTURES
9289 lw = (Scheme_Lightweight_Continuation *)jit_future_storage[2];
9290 #endif
9291 }
9292 }
9293
9294 MZ_CONT_MARK_POS = lw->saved_lwc->cont_mark_pos_end + cm_pos_delta;
9295
9296 return lw;
9297 }
9298
scheme_push_marks_from_lightweight_continuation(Scheme_Lightweight_Continuation * lw,Scheme_Cont_Frame_Data * d)9299 int scheme_push_marks_from_lightweight_continuation(Scheme_Lightweight_Continuation *lw,
9300 Scheme_Cont_Frame_Data *d)
9301 {
9302 intptr_t pos, len, delta;
9303 Scheme_Cont_Mark *seg;
9304
9305 len = (lw->saved_lwc->cont_mark_stack_end
9306 - lw->saved_lwc->cont_mark_stack_start);
9307
9308 if (len) {
9309 scheme_push_continuation_frame(d);
9310
9311 seg = lw->cont_mark_stack_slice;
9312
9313 delta = MZ_CONT_MARK_POS + 2 - lw->saved_lwc->cont_mark_pos_start;
9314
9315 for (pos = 0; pos < len; pos++) {
9316 MZ_CONT_MARK_POS = seg[pos].pos + delta;
9317 scheme_set_cont_mark(seg[pos].key, seg[pos].val);
9318 }
9319
9320 MZ_CONT_MARK_POS = lw->saved_lwc->cont_mark_pos_end + delta;
9321
9322 return 1;
9323 }
9324
9325 return 0;
9326 }
9327
scheme_push_marks_from_thread(Scheme_Thread * p2,Scheme_Cont_Frame_Data * d)9328 int scheme_push_marks_from_thread(Scheme_Thread *p2, Scheme_Cont_Frame_Data *d)
9329 {
9330 intptr_t i, pos, delta;
9331 Scheme_Cont_Mark *seg;
9332
9333 if (p2->cont_mark_stack) {
9334 scheme_push_continuation_frame(d);
9335
9336 delta = MZ_CONT_MARK_POS - p2->cont_mark_pos;
9337 if (delta < 0) delta = 0;
9338
9339 for (i = 0; i < p2->cont_mark_stack; i++) {
9340 seg = p2->cont_mark_stack_segments[i >> SCHEME_LOG_MARK_SEGMENT_SIZE];
9341 pos = i & SCHEME_MARK_SEGMENT_MASK;
9342
9343 MZ_CONT_MARK_POS = seg[pos].pos + delta;
9344 scheme_set_cont_mark(seg[pos].key, seg[pos].val);
9345 }
9346
9347 MZ_CONT_MARK_POS = p2->cont_mark_pos + delta;
9348
9349 return 1;
9350 }
9351
9352 return 0;
9353 }
9354
9355 #else
9356
scheme_init_thread_lwc(void)9357 void scheme_init_thread_lwc(void) XFORM_SKIP_PROC { }
9358
9359 #endif
9360
9361 /*========================================================================*/
9362 /* dynamic-wind */
9363 /*========================================================================*/
9364
9365 typedef struct {
9366 MZTAG_IF_REQUIRED
9367 Scheme_Object *pre, *act, *post;
9368 } Dyn_Wind;
9369
pre_post_dyn_wind(Scheme_Object * prepost)9370 static void pre_post_dyn_wind(Scheme_Object *prepost)
9371 {
9372 Scheme_Cont_Frame_Data cframe;
9373
9374 /* Cancel internal suspend in eval or dyn-wind, because we convert
9375 it to a parameterize. */
9376 --scheme_current_thread->suspend_break;
9377 ASSERT_SUSPEND_BREAK_ZERO();
9378
9379 scheme_push_break_enable(&cframe, 0, 0);
9380
9381 /* Here's the main call: */
9382 scheme_ignore_result(_scheme_apply_multi(prepost, 0, NULL));
9383
9384 scheme_pop_break_enable(&cframe, 0);
9385
9386 /* Restore internal suspend: */
9387 scheme_current_thread->suspend_break++;
9388 }
9389
do_dyn_wind(void * d)9390 static Scheme_Object *do_dyn_wind(void *d)
9391 {
9392 Dyn_Wind *dw;
9393 dw = (Dyn_Wind *)d;
9394
9395 return _scheme_apply_multi(dw->act, 0, NULL);
9396 }
9397
pre_dyn_wind(void * d)9398 static void pre_dyn_wind(void *d)
9399 {
9400 pre_post_dyn_wind(((Dyn_Wind *)d)->pre);
9401 }
9402
post_dyn_wind(void * d)9403 static void post_dyn_wind(void *d)
9404 {
9405 pre_post_dyn_wind(((Dyn_Wind *)d)->post);
9406 }
9407
dynamic_wind(int c,Scheme_Object * argv[])9408 static Scheme_Object *dynamic_wind(int c, Scheme_Object *argv[])
9409 {
9410 Dyn_Wind *dw;
9411 Scheme_Object *v;
9412
9413 scheme_check_proc_arity("dynamic-wind", 0, 0, c, argv);
9414 scheme_check_proc_arity("dynamic-wind", 0, 1, c, argv);
9415 scheme_check_proc_arity("dynamic-wind", 0, 2, c, argv);
9416
9417 dw = MALLOC_ONE_RT(Dyn_Wind);
9418 #ifdef MZTAG_REQUIRED
9419 dw->type = scheme_rt_dyn_wind_info;
9420 #endif
9421
9422 dw->pre = argv[0];
9423 dw->act = argv[1];
9424 dw->post = argv[2];
9425
9426 v = scheme_dynamic_wind(pre_dyn_wind, do_dyn_wind, post_dyn_wind, NULL,
9427 (void *)dw);
9428
9429 /* We may have just re-activated breaking: */
9430 {
9431 Scheme_Thread *p = scheme_current_thread;
9432 if (p->external_break && scheme_can_break(p)) {
9433 Scheme_Object **save_values;
9434 int save_count;
9435
9436 if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES)) {
9437 save_count = p->ku.multiple.count;
9438 save_values = p->ku.multiple.array;
9439 p->ku.multiple.array = NULL;
9440 if (SAME_OBJ(save_values, p->values_buffer))
9441 p->values_buffer = NULL;
9442 } else {
9443 save_count = 0;
9444 save_values = NULL;
9445 }
9446
9447 scheme_thread_block_w_thread(0.0, p);
9448 p->ran_some = 1;
9449
9450 if (save_values) {
9451 p->ku.multiple.count = save_count;
9452 p->ku.multiple.array = save_values;
9453 }
9454 }
9455 }
9456
9457 return v;
9458 }
9459
scheme_dynamic_wind(void (* pre)(void *),Scheme_Object * (* volatile act)(void *),void (* volatile post)(void *),Scheme_Object * (* jmp_handler)(void *),void * volatile data)9460 Scheme_Object *scheme_dynamic_wind(void (*pre)(void *),
9461 Scheme_Object *(* volatile act)(void *),
9462 void (* volatile post)(void *),
9463 Scheme_Object *(*jmp_handler)(void *),
9464 void * volatile data)
9465 {
9466 mz_jmp_buf newbuf;
9467 Scheme_Object * volatile v, ** volatile save_values;
9468 volatile int err;
9469 Scheme_Dynamic_Wind * volatile dw;
9470 volatile int save_count, old_cac;
9471 Scheme_Thread *p;
9472 int delta;
9473
9474 p = scheme_current_thread;
9475
9476 if (pre) {
9477 ASSERT_SUSPEND_BREAK_ZERO();
9478 p->suspend_break++;
9479 pre(data);
9480 p = scheme_current_thread;
9481 --p->suspend_break;
9482 }
9483
9484 /* set up `dw' after pre(), in case a continuation
9485 is captured in pre() and composed later */
9486
9487 dw = MALLOC_ONE_RT(Scheme_Dynamic_Wind);
9488 #ifdef MZTAG_REQUIRED
9489 dw->type = scheme_rt_dyn_wind;
9490 #endif
9491
9492 dw->data = data;
9493 dw->pre = pre;
9494 dw->post = post;
9495 dw->prev = p->dw;
9496 if (dw->prev)
9497 dw->depth = dw->prev->depth + 1;
9498 else
9499 dw->depth = 0;
9500 dw->next_meta = p->next_meta;
9501
9502 p->next_meta = 0;
9503 p->dw = dw;
9504
9505 dw->saveerr = scheme_current_thread->error_buf;
9506 scheme_current_thread->error_buf = &newbuf;
9507
9508 scheme_save_env_stack_w_thread(dw->envss, p);
9509
9510 if (scheme_setjmp(newbuf)) {
9511 p = scheme_current_thread;
9512 scheme_restore_env_stack_w_thread(dw->envss, p);
9513 if ((p->dw != dw)
9514 && (!p->dw || !dw->id || (p->dw->id != dw->id))) {
9515 /* A full continuation jump was interrupted by an
9516 escape continuation jump (in a dw pre or post thunk). Either
9517 1. this dw's post is already done for an interupted upward
9518 jump; or
9519 2. we never actually got this far for an interrupted
9520 downward jump.
9521 In either case, skip up until we get to the right level. */
9522 scheme_longjmp(*dw->saveerr, 1);
9523 } else {
9524 if (jmp_handler)
9525 v = jmp_handler(data);
9526 else
9527 v = NULL;
9528 err = !v;
9529 }
9530 } else {
9531 if (pre) {
9532 /* Need to check for a break, in case one was queued during
9533 pre: */
9534 scheme_check_break_now();
9535 }
9536
9537 v = act(data);
9538
9539 err = 0;
9540 }
9541
9542 p = scheme_current_thread;
9543 if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES)) {
9544 save_count = p->ku.multiple.count;
9545 save_values = p->ku.multiple.array;
9546 p->ku.multiple.array = NULL;
9547 if (SAME_OBJ(save_values, p->values_buffer))
9548 p->values_buffer = NULL;
9549 } else {
9550 save_count = 0;
9551 save_values = NULL;
9552 }
9553
9554 delta = p->dw->next_meta;
9555 p->dw = p->dw->prev; /* note: use p->dw, not dw, in case
9556 continuation was composed */
9557 p->next_meta += delta;
9558
9559 /* Don't run Racket-based dyn-winds when we're killing a nested thread. */
9560 if (err && p->cjs.is_kill && (post == post_dyn_wind))
9561 post = NULL;
9562
9563 old_cac = scheme_continuation_application_count;
9564
9565 if (post) {
9566 p->error_buf = &newbuf;
9567 if (scheme_setjmp(newbuf)) {
9568 p = scheme_current_thread;
9569 scheme_restore_env_stack_w_thread(dw->envss, p);
9570 err = 1;
9571 } else {
9572 Scheme_Continuation_Jump_State cjs;
9573 p = scheme_current_thread;
9574 if (!p->cjs.skip_dws) {
9575 ASSERT_SUSPEND_BREAK_ZERO();
9576 p->suspend_break++;
9577 copy_cjs(&cjs, &p->cjs);
9578 reset_cjs(&p->cjs);
9579 post(data);
9580 copy_cjs(&p->cjs, &cjs);
9581 p = scheme_current_thread;
9582 --p->suspend_break;
9583 }
9584 }
9585 }
9586
9587 if (err) {
9588 /* If we're escaping to a prompt or escape continuation,
9589 check that it's still there. */
9590 if ((old_cac != scheme_continuation_application_count)
9591 && p->cjs.jumping_to_continuation) {
9592 p->error_buf = dw->saveerr;
9593 if (SAME_TYPE(SCHEME_TYPE(p->cjs.jumping_to_continuation), scheme_prompt_type)) {
9594 Scheme_Object *tag;
9595 Scheme_Prompt *prompt;
9596 tag = ((Scheme_Prompt *)p->cjs.jumping_to_continuation)->tag;
9597 prompt = (Scheme_Prompt *)scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(tag));
9598 if (!prompt && SAME_OBJ(scheme_default_prompt_tag, tag)) {
9599 prompt = original_default_prompt;
9600 }
9601 if (!prompt) {
9602 scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
9603 "abort-current-continuation:"
9604 " abort in progress, but current continuation includes"
9605 " no prompt with the given tag"
9606 " after a `dynamic-wind' post-thunk return\n"
9607 " tag: %V",
9608 tag);
9609 return NULL;
9610 }
9611 p->cjs.jumping_to_continuation = (Scheme_Object *)prompt;
9612 } else if (SCHEME_ECONTP(p->cjs.jumping_to_continuation)) {
9613 if (!scheme_escape_continuation_ok(p->cjs.jumping_to_continuation)) {
9614 if (p->cjs.alt_full_continuation) {
9615 /* We were trying to execute a full-continuation jump through
9616 an escape-continuation jump. Go back to full-jump mode. */
9617 return jump_to_alt_continuation();
9618 }
9619 scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
9620 "continuation application: lost target;\n"
9621 " jump to escape continuation in progress, and the target is not in the\n"
9622 " current continuation after a `dynamic-wind' post-thunk return");
9623 return NULL;
9624 }
9625 }
9626 }
9627
9628 scheme_longjmp(*dw->saveerr, 1);
9629 }
9630
9631 p->error_buf = dw->saveerr;
9632
9633 if (post) {
9634 /* Need to check for a break, in case one was queued during post: */
9635 scheme_check_break_now();
9636 }
9637
9638 if (v == SCHEME_MULTIPLE_VALUES) {
9639 p->ku.multiple.count = save_count;
9640 p->ku.multiple.array = save_values;
9641 }
9642
9643 return v;
9644 }
9645
scheme_apply_dw_in_meta(Scheme_Dynamic_Wind * dw,int post_part,int meta_depth,Scheme_Cont * recheck)9646 void scheme_apply_dw_in_meta(Scheme_Dynamic_Wind *dw, int post_part, int meta_depth, Scheme_Cont *recheck)
9647 {
9648 /* Run the given dw pre/post thunk, but let it see only the
9649 continuation marks starting with the given meta-continuation.
9650 We don't want to actually prune the meta-continuation, since
9651 that would be out of sync with the control state, so we instead
9652 replace the first meta_depth frames to prune the continuation marks.
9653 On return, we have to unprune those marks. (If there's an escape,
9654 then we don't have to unprune, because the escape jumps out of
9655 the pruned meta-continuations.) Unfortunately, pruning this way
9656 requires time proportional to the meta depth.
9657
9658 The pre/post thunk might install it's own marks. In that case, it
9659 uses the current mark stack. We don't care about the current mark
9660 stack's state, since we're either on our way out, or we're on our
9661 way in and we haven't started restoring the marks. So start with
9662 a clean mark stack, but make sure it doesn't appear to be in tail
9663 position for a meta-continuation.
9664
9665 The pre/post thunk might jump, or it might capture a continuation that
9666 is later restored. In that case, the meta-continuation can be extended
9667 or different by the time we get back. That's why we take a meta_depth,
9668 rather than a meta continuation (i.e., the loop that calls this
9669 function shouldn't remember meta-continuations). The meta-continuation
9670 can't become shorter than the current needed meta_depth. It may become
9671 shorter than it was originally, which is relevant to a post loop that
9672 calls this function; but the d-w list for posts will become shorter in
9673 that case, too, so the post loop is fine as long as it consults
9674 scheme_current_thread->dw.
9675 */
9676 Scheme_Thread *p = scheme_current_thread;
9677 Scheme_Meta_Continuation *mc, *old_mc, *rest;
9678 intptr_t delta;
9679 int i, actual_depth;
9680 int old_cac;
9681
9682 MZ_CONT_MARK_STACK = p->cont_mark_stack_bottom;
9683 MZ_CONT_MARK_POS = p->meta_continuation->meta_tail_pos + 2;
9684
9685 old_mc = p->meta_continuation;
9686
9687 /* clone the first meta_depth meta continuations: */
9688 for (i = 0, actual_depth = 0, rest = old_mc; i < meta_depth; actual_depth++) {
9689 if (rest->overflow)
9690 i++;
9691 rest = rest->next;
9692 }
9693 mc = clone_meta_cont(p->meta_continuation, NULL, actual_depth, NULL, NULL, rest, 0);
9694 p->meta_continuation = mc;
9695
9696 /* strip the marks of the first actual_depth-1 meta continuations */
9697 rest = mc;
9698 for (i = 0; i < actual_depth - 1; i++) {
9699 rest->cont_mark_total = 0;
9700 rest->cont_mark_offset = rest->cont_mark_stack;
9701 rest->cont_mark_stack_copied = NULL;
9702 sync_meta_cont(rest);
9703 rest = rest->next;
9704 }
9705
9706 /* prune the actual_depth's meta continuation's marks. */
9707 delta = rest->cont_mark_stack - dw->envss.cont_mark_stack;
9708 if (delta) {
9709 rest->cont_mark_total -= delta;
9710 rest->cont_mark_stack -= delta;
9711 if (rest->cont_mark_total) {
9712 Scheme_Cont_Mark *cp;
9713 cp = MALLOC_N(Scheme_Cont_Mark, rest->cont_mark_total);
9714 memcpy(cp, rest->cont_mark_stack_copied, rest->cont_mark_total * sizeof(Scheme_Cont_Mark));
9715 rest->cont_mark_stack_copied = cp;
9716 } else
9717 rest->cont_mark_stack_copied = NULL;
9718 sync_meta_cont(rest);
9719 }
9720
9721 old_cac = scheme_continuation_application_count;
9722
9723 /* Run the post or pre thunk: */
9724 if (post_part) {
9725 DW_PrePost_Proc post = dw->post;
9726 post(dw->data);
9727 } else {
9728 DW_PrePost_Proc pre = dw->pre;
9729 pre(dw->data);
9730 }
9731
9732 p = scheme_current_thread;
9733
9734 if (recheck && !recheck->composable) {
9735 if (scheme_continuation_application_count != old_cac) {
9736 scheme_recheck_prompt_and_barrier(recheck);
9737 }
9738 }
9739
9740 /* restore the first meta_depth meta continuations (onto
9741 a tail that is possibly different than when we captured
9742 old_mc) */
9743 for (i = 0, rest = p->meta_continuation; i < actual_depth; i++) {
9744 rest = rest->next;
9745 }
9746 old_mc = clone_meta_cont(old_mc, NULL, actual_depth, NULL, NULL, rest, 0);
9747 p->meta_continuation = old_mc;
9748 }
9749
jump_to_alt_continuation()9750 static Scheme_Object *jump_to_alt_continuation()
9751 {
9752 Scheme_Thread *p;
9753 Scheme_Object *a[1], **args, *fc;
9754
9755 p = scheme_current_thread;
9756
9757 a[0] = p->cjs.val;
9758 fc = p->cjs.alt_full_continuation;
9759 args = ((p->cjs.num_vals == 1) ? a : (Scheme_Object **)p->cjs.val);
9760 p->cjs.jumping_to_continuation = NULL;
9761 p->cjs.alt_full_continuation = NULL;
9762 p->cjs.val = NULL;
9763 p->cjs.skip_dws = 0;
9764
9765 return scheme_jump_to_continuation(fc, p->cjs.num_vals, args, NULL, 0);
9766 }
9767
9768 /*========================================================================*/
9769 /* time */
9770 /*========================================================================*/
9771
scheme_get_milliseconds(void)9772 uintptr_t scheme_get_milliseconds(void)
9773 /* this function can be called from any OS thread */
9774 {
9775 return rktio_get_milliseconds();
9776 }
9777
scheme_get_inexact_milliseconds(void)9778 double scheme_get_inexact_milliseconds(void)
9779 /* this function can be called from any OS thread */
9780 {
9781 return rktio_get_inexact_milliseconds();
9782 }
9783
get_inexact_monotonic_milliseconds(void)9784 static double get_inexact_monotonic_milliseconds(void)
9785 /* this function can be called from any OS thread */
9786 {
9787 return rktio_get_inexact_monotonic_milliseconds(scheme_rktio);
9788 }
9789
scheme_get_process_milliseconds(void)9790 intptr_t scheme_get_process_milliseconds(void)
9791 {
9792 return rktio_get_process_milliseconds(scheme_rktio);
9793 }
9794
scheme_get_process_children_milliseconds(void)9795 intptr_t scheme_get_process_children_milliseconds(void)
9796 {
9797 return rktio_get_process_children_milliseconds(scheme_rktio);
9798 }
9799
scheme_get_thread_milliseconds(Scheme_Object * thrd)9800 intptr_t scheme_get_thread_milliseconds(Scheme_Object *thrd)
9801 XFORM_SKIP_PROC
9802 {
9803 Scheme_Thread *t = thrd ? (Scheme_Thread *)thrd : scheme_current_thread;
9804
9805 if (t == scheme_current_thread) {
9806 intptr_t cpm;
9807 cpm = scheme_get_process_milliseconds();
9808 return t->accum_process_msec + (cpm - t->current_start_process_msec);
9809 } else {
9810 return t->accum_process_msec;
9811 }
9812 }
9813
scheme_get_seconds(void)9814 intptr_t scheme_get_seconds(void)
9815 {
9816 return rktio_get_seconds(scheme_rktio);
9817 }
9818
seconds_to_date(int argc,Scheme_Object ** argv)9819 static Scheme_Object *seconds_to_date(int argc, Scheme_Object **argv)
9820 {
9821 intptr_t lnow;
9822 int get_gmt;
9823 rktio_date_t *dt;
9824 Scheme_Object *p[12], *secs, *nsecs, *zname;
9825 char *tzn;
9826
9827 secs = argv[0];
9828
9829 if (!SCHEME_REALP(secs)) {
9830 scheme_wrong_contract("seconds->date", "real?", 0, argc, argv);
9831 return NULL;
9832 }
9833
9834 if (argc > 1)
9835 get_gmt = SCHEME_FALSEP(argv[1]);
9836 else
9837 get_gmt = 0;
9838
9839 if (SCHEME_INTP(secs) || SCHEME_BIGNUMP(secs)) {
9840 nsecs = scheme_make_integer(0);
9841 } else {
9842 p[0] = secs;
9843 secs = scheme_inexact_to_exact(1, p);
9844 nsecs = secs;
9845 p[0] = secs;
9846 secs = scheme_floor(1, p);
9847 nsecs = scheme_bin_minus(nsecs, secs);
9848 nsecs = scheme_bin_mult(nsecs, scheme_make_integer(1000000000));
9849 p[0] = nsecs;
9850 nsecs = scheme_floor(1, p);
9851 p[0] = nsecs;
9852 nsecs = scheme_inexact_to_exact(1, p);
9853 p[0] = secs;
9854 secs = scheme_inexact_to_exact(1, p);
9855 }
9856
9857 if (scheme_get_time_val(secs, &lnow)) {
9858 dt = rktio_seconds_to_date(scheme_rktio, lnow, SCHEME_INT_VAL(nsecs), get_gmt);
9859 if (dt) {
9860 tzn = dt->zone_name;
9861 if (!tzn)
9862 tzn = "?";
9863 zname = scheme_make_utf8_string(tzn);
9864 SCHEME_SET_IMMUTABLE(zname);
9865
9866 p[0] = scheme_make_integer(dt->second);
9867 p[1] = scheme_make_integer(dt->minute);
9868 p[2] = scheme_make_integer(dt->hour);
9869 p[3] = scheme_make_integer(dt->day);
9870 p[4] = scheme_make_integer(dt->month);
9871 p[5] = scheme_make_integer(dt->year);
9872 p[6] = scheme_make_integer(dt->day_of_week);
9873 p[7] = scheme_make_integer(dt->day_of_year);
9874 p[8] = (dt->is_dst ? scheme_true : scheme_false);
9875 p[9] = scheme_make_integer(dt->zone_offset);
9876 p[10] = scheme_make_integer(dt->nanosecond);
9877 p[11] = zname;
9878
9879 if (dt->zone_name)
9880 rktio_free(dt->zone_name);
9881 free(dt);
9882
9883 return scheme_make_struct_instance(scheme_date, 12, p);
9884 } else if ((rktio_get_last_error(scheme_rktio) != RKTIO_ERROR_TIME_OUT_OF_RANGE)
9885 || (rktio_get_last_error_kind(scheme_rktio) != RKTIO_ERROR_KIND_RACKET)) {
9886 scheme_raise_exn(MZEXN_FAIL,
9887 "seconds->date: conversion error\n"
9888 " error: %d; %s",
9889 rktio_get_last_error(scheme_rktio),
9890 rktio_get_last_error_string(scheme_rktio));
9891 }
9892 }
9893
9894 scheme_raise_exn(MZEXN_FAIL,
9895 "seconds->date: integer is out-of-range\n"
9896 " integer: %V",
9897 secs);
9898
9899 return NULL;
9900 }
9901
time_apply(int argc,Scheme_Object * argv[])9902 static Scheme_Object *time_apply(int argc, Scheme_Object *argv[])
9903 {
9904 double start, end;
9905 uintptr_t cpustart, cpuend;
9906 uintptr_t gcstart, gcend;
9907 uintptr_t dur, cpudur, gcdur;
9908 int i, num_rands;
9909 Scheme_Object *v, *p[4], **rand_vec, *rands, *r;
9910
9911 if (!SCHEME_PROCP(argv[0]))
9912 scheme_wrong_contract("time-apply", "procedure?", 0, argc, argv);
9913
9914 rands = argv[1];
9915
9916 num_rands = 0;
9917 r = rands;
9918 while (!SCHEME_NULLP(r)) {
9919 if (!SCHEME_PAIRP(r))
9920 scheme_wrong_contract("time-apply", "list?", 1, argc, argv);
9921 r = SCHEME_CDR(r);
9922 num_rands++;
9923 }
9924
9925 if (SCHEME_FALSEP(get_or_check_arity(argv[0], num_rands, NULL, 1))) {
9926 scheme_contract_error("time-apply",
9927 "arity mismatch between procedure and argument-list length\n",
9928 "procedure", 1, argv[0],
9929 "argument-list length", 1, scheme_make_integer(num_rands),
9930 NULL);
9931 return NULL;
9932 }
9933
9934 rand_vec = MALLOC_N(Scheme_Object *, num_rands);
9935 for (i = 0; SCHEME_PAIRP(rands); i++, rands = SCHEME_CDR(rands)) {
9936 rand_vec[i] = SCHEME_CAR(rands);
9937 }
9938
9939 gcstart = scheme_total_gc_time;
9940 start = get_inexact_monotonic_milliseconds();
9941 cpustart = scheme_get_process_milliseconds();
9942 v = _scheme_apply_multi(argv[0], num_rands, rand_vec);
9943 cpuend = scheme_get_process_milliseconds();
9944 end = get_inexact_monotonic_milliseconds();
9945 gcend = scheme_total_gc_time;
9946
9947 dur = (uintptr_t)(end - start);
9948 cpudur = cpuend - cpustart;
9949 gcdur = gcend - gcstart;
9950
9951 if (v == SCHEME_MULTIPLE_VALUES) {
9952 Scheme_Thread *cp = scheme_current_thread;
9953 Scheme_Object **args;
9954 if (SAME_OBJ(cp->ku.multiple.array, cp->values_buffer))
9955 cp->values_buffer = NULL;
9956 args = cp->ku.multiple.array;
9957 cp->ku.multiple.array = NULL;
9958 v = scheme_build_list(cp->ku.multiple.count, args);
9959 } else
9960 v = scheme_make_pair(v, scheme_null);
9961
9962 p[0] = v;
9963 p[1] = scheme_make_integer(cpudur);
9964 p[2] = scheme_make_integer(dur);
9965 p[3] = scheme_make_integer(gcdur);
9966
9967 return scheme_values(4, p);
9968 }
9969
current_milliseconds(int argc,Scheme_Object ** argv)9970 static Scheme_Object *current_milliseconds(int argc, Scheme_Object **argv)
9971 {
9972 return scheme_make_integer(scheme_get_milliseconds());
9973 }
9974
current_inexact_milliseconds(int argc,Scheme_Object ** argv)9975 static Scheme_Object *current_inexact_milliseconds(int argc, Scheme_Object **argv)
9976 {
9977 return scheme_make_double(scheme_get_inexact_milliseconds());
9978 }
9979
current_inexact_monotonic_milliseconds(int argc,Scheme_Object ** argv)9980 static Scheme_Object *current_inexact_monotonic_milliseconds(int argc, Scheme_Object **argv)
9981 {
9982 return scheme_make_double(get_inexact_monotonic_milliseconds());
9983 }
9984
current_process_milliseconds(int argc,Scheme_Object ** argv)9985 static Scheme_Object *current_process_milliseconds(int argc, Scheme_Object **argv)
9986 {
9987 if (!argc || SCHEME_FALSEP(argv[0]))
9988 return scheme_make_integer(scheme_get_process_milliseconds());
9989 else if (SAME_OBJ(argv[0], subprocesses_symbol))
9990 return scheme_make_integer(scheme_get_process_children_milliseconds());
9991 else {
9992 if (SCHEME_THREADP(argv[0]))
9993 return scheme_make_integer(scheme_get_thread_milliseconds(argv[0]));
9994 scheme_wrong_contract("current-process-milliseconds", "(or/c #f thread? 'subprocesses)", 0, argc, argv);
9995 return NULL;
9996 }
9997 }
9998
current_gc_milliseconds(int argc,Scheme_Object ** argv)9999 static Scheme_Object *current_gc_milliseconds(int argc, Scheme_Object **argv)
10000 {
10001 return scheme_make_integer(scheme_total_gc_time);
10002 }
10003
current_seconds(int argc,Scheme_Object ** argv)10004 static Scheme_Object *current_seconds(int argc, Scheme_Object **argv)
10005 {
10006 intptr_t secs;
10007 secs = scheme_get_seconds();
10008 return scheme_make_integer_value_from_time(secs);
10009 }
10010
10011
10012 /*========================================================================*/
10013 /* read-eval-print */
10014 /*========================================================================*/
10015
10016 static Scheme_Object *
current_print(int argc,Scheme_Object ** argv)10017 current_print(int argc, Scheme_Object **argv)
10018 {
10019 return scheme_param_config("current-print",
10020 scheme_make_integer(MZCONFIG_PRINT_HANDLER),
10021 argc, argv,
10022 1, NULL, NULL, 0);
10023 }
10024
10025 static Scheme_Object *
current_prompt_read(int argc,Scheme_Object ** argv)10026 current_prompt_read(int argc, Scheme_Object **argv)
10027 {
10028 return scheme_param_config("current-prompt-read",
10029 scheme_make_integer(MZCONFIG_PROMPT_READ_HANDLER),
10030 argc, argv,
10031 0, NULL, NULL, 0);
10032 }
10033
10034 static Scheme_Object *
current_read(int argc,Scheme_Object ** argv)10035 current_read(int argc, Scheme_Object **argv)
10036 {
10037 return scheme_param_config("current-read-interaction",
10038 scheme_make_integer(MZCONFIG_READ_HANDLER),
10039 argc, argv,
10040 2, NULL, NULL, 0);
10041 }
10042
10043 static Scheme_Object *
current_get_read_input_port(int argc,Scheme_Object ** argv)10044 current_get_read_input_port(int argc, Scheme_Object **argv)
10045 {
10046 return scheme_param_config("current-get-interaction-input-port",
10047 scheme_make_integer(MZCONFIG_READ_INPUT_PORT_HANDLER),
10048 argc, argv,
10049 0, NULL, NULL, 0);
10050 }
10051
10052 Scheme_Object *
scheme_default_print_handler(int argc,Scheme_Object * argv[])10053 scheme_default_print_handler(int argc, Scheme_Object *argv[])
10054 {
10055 Scheme_Object *obj = argv[0];
10056
10057 if (!SAME_OBJ(obj, scheme_void)) {
10058 Scheme_Config *config;
10059 Scheme_Object *port;
10060 Scheme_Object *argv[2];
10061
10062 config = scheme_current_config();
10063 port = scheme_get_param(config, MZCONFIG_OUTPUT_PORT);
10064
10065 argv[0] = obj;
10066 argv[1] = port;
10067 _scheme_apply(scheme_print_proc, 2, argv);
10068 scheme_write_byte_string("\n", 1, port);
10069 }
10070
10071 return scheme_void;
10072 }
10073
10074 Scheme_Object *
scheme_default_read_input_port_handler(int argc,Scheme_Object * argv[])10075 scheme_default_read_input_port_handler(int argc, Scheme_Object *argv[])
10076 {
10077 Scheme_Object *inport;
10078
10079 inport = scheme_get_param(scheme_current_config(), MZCONFIG_INPUT_PORT);
10080
10081 if (inport == scheme_orig_stdin_port)
10082 scheme_flush_orig_outputs();
10083
10084 return inport;
10085 }
10086
10087 Scheme_Object *
scheme_default_prompt_read_handler(int argc,Scheme_Object * argv[])10088 scheme_default_prompt_read_handler(int argc, Scheme_Object *argv[])
10089 {
10090 Scheme_Config *config;
10091 Scheme_Object *port, *reader, *getter;
10092 Scheme_Object *inport, *name, *a[4], *v;
10093
10094 config = scheme_current_config();
10095 port = scheme_get_param(config, MZCONFIG_OUTPUT_PORT);
10096
10097 scheme_write_byte_string("> ", 2, port);
10098 scheme_flush_output(port);
10099
10100 getter = scheme_get_param(config, MZCONFIG_READ_INPUT_PORT_HANDLER);
10101 inport = _scheme_apply(getter, 0, NULL);
10102
10103 if (!SCHEME_INPORTP(inport))
10104 scheme_wrong_contract("default-prompt-read-hander", "input-port?", -1, -1, &inport);
10105
10106 name = (Scheme_Object *)scheme_port_record(inport);
10107 name = ((Scheme_Input_Port *)name)->name;
10108
10109 reader = scheme_get_param(config, MZCONFIG_READ_HANDLER);
10110
10111 a[0] = name;
10112 a[1] = inport;
10113 v = _scheme_apply(reader, 2, a);
10114
10115 a[0] = inport;
10116 if (SCHEME_TRUEP(scheme_terminal_port_p(1, a))) {
10117 a[0] = port;
10118 if (SCHEME_TRUEP(scheme_terminal_port_p(1, a))) {
10119 intptr_t line, col, pos;
10120 scheme_tell_all(port, &line, &col, &pos);
10121 if ((col > 0) && (line > 0)) {
10122 /* input and output are terminals (assume the same one),
10123 and the output port counts lines: tell output port
10124 that it's on a new line: */
10125 a[0] = port;
10126 a[1] = scheme_make_integer(line + 1);
10127 a[2] = scheme_make_integer(0);
10128 if (pos > 0)
10129 a[3] = scheme_make_integer(pos + 2); /* incremet plus 0-adjust */
10130 else
10131 a[3] = scheme_false;
10132 scheme_set_port_location(4, a);
10133 }
10134 }
10135 }
10136
10137 return v;
10138 }
10139
10140 Scheme_Object *
scheme_default_read_handler(int argc,Scheme_Object * argv[])10141 scheme_default_read_handler(int argc, Scheme_Object *argv[])
10142 {
10143 Scheme_Config *config;
10144 Scheme_Object *name = argv[0];
10145 Scheme_Object *inport = argv[1];
10146 Scheme_Object *stx;
10147 Scheme_Cont_Frame_Data cframe;
10148
10149 if (!SCHEME_INPORTP(inport))
10150 scheme_wrong_contract("default-read-interaction-handler",
10151 "input-port?",
10152 1,
10153 argc,
10154 argv);
10155
10156 config = scheme_current_config();
10157 // FIXME
10158 // config = scheme_extend_config(config, MZCONFIG_CAN_READ_READER, scheme_true);
10159 // config = scheme_extend_config(config, MZCONFIG_CAN_READ_LANG, scheme_false);
10160
10161 scheme_push_continuation_frame(&cframe);
10162 scheme_install_config(config);
10163
10164 stx = scheme_read_syntax(inport, name);
10165
10166 scheme_pop_continuation_frame(&cframe);
10167
10168 return stx;
10169 }
10170
10171 /*========================================================================*/
10172 /* precise GC */
10173 /*========================================================================*/
10174
10175 #ifdef MZ_PRECISE_GC
10176
10177 START_XFORM_SKIP;
10178
10179 #include "mzmark_fun.inc"
10180
register_traversers(void)10181 static void register_traversers(void)
10182 {
10183 GC_REG_TRAV(scheme_rt_dyn_wind_cell, mark_dyn_wind_cell);
10184 GC_REG_TRAV(scheme_rt_dyn_wind_info, mark_dyn_wind_info);
10185 GC_REG_TRAV(scheme_cont_mark_chain_type, mark_cont_mark_chain);
10186 #ifdef MZ_USE_JIT
10187 GC_REG_TRAV(scheme_rt_lightweight_cont, mark_lightweight_cont);
10188 #endif
10189 }
10190
10191 END_XFORM_SKIP;
10192
10193 #endif
10194