1 #include "schpriv.h"
2 #include <string.h>
3
4 /* types should all be registered before invoking places */
5
6 SHARED_OK Scheme_Equal_Proc *scheme_type_equals;
7 SHARED_OK Scheme_Primary_Hash_Proc *scheme_type_hash1s;
8 SHARED_OK Scheme_Secondary_Hash_Proc *scheme_type_hash2s;
9
10 SHARED_OK static char **type_names;
11 SHARED_OK static Scheme_Type maxtype, allocmax;
12
13 #ifdef MEMORY_COUNTING_ON
14 SHARED_OK intptr_t scheme_type_table_count;
15 #endif
16
17 #ifdef MZ_USE_PLACES
18 static mzrt_mutex *type_array_mutex;
19 #endif
20
21 #define RAW_MALLOC_N(t, n) (t*)malloc(n * sizeof(t))
22
init_type_arrays()23 static void init_type_arrays()
24 {
25 intptr_t n;
26
27 #ifdef MZ_USE_PLACES
28 mzrt_mutex_create(&type_array_mutex);
29 #endif
30
31 REGISTER_SO(type_names);
32 REGISTER_SO(scheme_type_equals);
33 REGISTER_SO(scheme_type_hash1s);
34 REGISTER_SO(scheme_type_hash2s);
35
36 maxtype = _scheme_last_type_;
37 allocmax = maxtype + 100;
38
39 type_names = RAW_MALLOC_N(char *, allocmax);
40 memset(type_names, 0, allocmax * sizeof(char *));
41
42 #ifdef MEMORY_COUNTING_ON
43 scheme_type_table_count += n;
44 scheme_misc_count += (allocmax * sizeof(char *));
45 #endif
46
47 #ifdef MEMORY_COUNTING_ON
48 scheme_type_table_count += n;
49 #endif
50
51 scheme_type_equals = RAW_MALLOC_N(Scheme_Equal_Proc, allocmax);
52 n = allocmax * sizeof(Scheme_Equal_Proc);
53 memset(scheme_type_equals, 0, n);
54
55 scheme_type_hash1s = RAW_MALLOC_N(Scheme_Primary_Hash_Proc, allocmax);
56 n = allocmax * sizeof(Scheme_Primary_Hash_Proc);
57 memset(scheme_type_hash1s, 0, n);
58
59 scheme_type_hash2s = RAW_MALLOC_N(Scheme_Secondary_Hash_Proc, allocmax);
60 n = allocmax * sizeof(Scheme_Secondary_Hash_Proc);
61 memset(scheme_type_hash2s, 0, n);
62 }
63
64 void
scheme_init_type()65 scheme_init_type ()
66 {
67 if (!type_names)
68 init_type_arrays();
69
70 #define set_name(t, n) type_names[t] = n
71
72 set_name(scheme_true_type, "<true>");
73 set_name(scheme_false_type, "<false>");
74 set_name(scheme_char_type, "<char>");
75 set_name(scheme_local_type, "<local-code>");
76 set_name(scheme_local_unbox_type, "<local-unbox-code>");
77 set_name(scheme_variable_type, "<global-variable-code>");
78 set_name(scheme_toplevel_type, "<variable-code>");
79 set_name(scheme_static_toplevel_type, "<variable-code>");
80 set_name(scheme_application_type, "<application-code>");
81 set_name(scheme_application2_type, "<unary-application-code>");
82 set_name(scheme_application3_type, "<binary-application-code>");
83 set_name(scheme_ir_lambda_type, "<procedure-semi-code>");
84 set_name(scheme_lambda_type, "<procedure-code>");
85 set_name(scheme_branch_type, "<branch-code>");
86 set_name(scheme_sequence_type, "<sequence-code>");
87 set_name(scheme_with_cont_mark_type, "<with-continuation-mark-code>");
88
89 set_name(scheme_define_values_type, "<define-values-code>");
90 set_name(scheme_begin0_sequence_type, "<begin0-code>");
91 set_name(scheme_inline_variant_type, "<inline-variant-code>");
92 set_name(scheme_set_bang_type, "<set!-code>");
93 set_name(scheme_boxenv_type, "<boxenv-code>");
94 set_name(scheme_varref_form_type, "<varref-code>");
95 set_name(scheme_apply_values_type, "<apply-values-code>");
96 set_name(scheme_with_immed_mark_type, "<with-immediate-mark-code>");
97 set_name(scheme_case_lambda_sequence_type, "<case-lambda-code>");
98
99 set_name(scheme_let_value_type, "<let-value-code>");
100 set_name(scheme_let_void_type, "<let-void-code>");
101 set_name(scheme_ir_local_type, "<local-semi-code>");
102 set_name(scheme_ir_let_value_type, "<let-value-semi-code>");
103 set_name(scheme_ir_let_header_type, "<let-header-semi-code>");
104 set_name(scheme_ir_toplevel_type, "<variable-semi-code>");
105 set_name(scheme_letrec_type, "<letrec-code>");
106 set_name(scheme_let_one_type, "<let-one-code>");
107 set_name(scheme_quote_compilation_type, "<quote-code>");
108
109 set_name(scheme_linklet_type, "<linklet>");
110 set_name(scheme_instance_type, "<instance>");
111 set_name(scheme_linklet_bundle_type, "<linklet-bundle>");
112
113 set_name(scheme_eval_waiting_type, "<eval-waiting>");
114 set_name(scheme_void_type, "<void>");
115 set_name(scheme_prim_type, "<procedure>");
116 set_name(scheme_closed_prim_type, "<procedure>");
117 set_name(scheme_closure_type, "<procedure>");
118 set_name(scheme_native_closure_type, "<procedure>");
119 set_name(scheme_cont_type, "<continuation>");
120 set_name(scheme_tail_call_waiting_type, "<tail-call-waiting>");
121 set_name(scheme_null_type, "<empty-list>");
122 set_name(scheme_pair_type, "<pair>");
123 set_name(scheme_mutable_pair_type, "<mutable-pair>");
124 set_name(scheme_raw_pair_type, "<raw-pair>");
125 set_name(scheme_box_type, "<box>");
126 set_name(scheme_integer_type, "<fixnum-integer>");
127 set_name(scheme_double_type, "<inexact-number>");
128 set_name(scheme_long_double_type, "<extflonum>");
129 set_name(scheme_float_type, "<inexact-number*>");
130 set_name(scheme_undefined_type, "<unsafe-undefined>");
131 set_name(scheme_eof_type, "<eof>");
132 set_name(scheme_input_port_type, "<input-port>");
133 set_name(scheme_output_port_type, "<output-port>");
134 set_name(scheme_thread_type, "<thread>");
135 set_name(scheme_char_string_type, "<string>");
136 set_name(scheme_byte_string_type, "<byte-string>");
137 set_name(scheme_unix_path_type, "<unix-path>");
138 set_name(scheme_windows_path_type, "<windows-path>");
139 set_name(scheme_struct_property_type, "<struct-property>");
140 set_name(scheme_chaperone_property_type, "<chaperone-property>");
141 set_name(scheme_structure_type, "<struct>");
142 set_name(scheme_proc_chaperone_type, "<chaperone>");
143 set_name(scheme_chaperone_type, "<chaperone>");
144 #ifdef USE_SENORA_GC
145 set_name(scheme_proc_struct_type, "<procedure-struct>");
146 #else
147 set_name(scheme_proc_struct_type, "<struct>");
148 #endif
149 set_name(scheme_symbol_type, "<symbol>");
150 set_name(scheme_keyword_type, "<keyword>");
151 set_name(scheme_primitive_syntax_type, "<primitive-syntax>");
152 set_name(scheme_macro_type, "<macro>");
153 set_name(scheme_vector_type, "<vector>");
154 set_name(scheme_flvector_type, "<flvector>");
155 set_name(scheme_extflvector_type, "<extflvector>");
156 set_name(scheme_fxvector_type, "<fxvector>");
157 set_name(scheme_bignum_type, "<bignum-integer>");
158 set_name(scheme_escaping_cont_type, "<escape-continuation>");
159 set_name(scheme_sema_type, "<semaphore>");
160 set_name(scheme_channel_type, "<channel>");
161 set_name(scheme_channel_put_type, "<channel-put>");
162 set_name(scheme_hash_table_type, "<hash>");
163 set_name(scheme_hash_tree_type, "<hash>");
164 set_name(scheme_eq_hash_tree_type, "<hash>");
165 set_name(scheme_eqv_hash_tree_type, "<hash>");
166 set_name(scheme_hash_tree_indirection_type, "<hash>");
167 set_name(scheme_hash_tree_subtree_type, "<hash-node>");
168 set_name(scheme_hash_tree_collision_type, "<hash-node>");
169 set_name(scheme_bucket_table_type, "<hash>");
170 set_name(scheme_case_closure_type, "<procedure>");
171 set_name(scheme_placeholder_type, "<placeholder>");
172 set_name(scheme_table_placeholder_type, "<hash-table-placeholder>");
173 set_name(scheme_weak_box_type, "<weak-box>");
174 set_name(scheme_ephemeron_type, "<ephemeron>");
175 set_name(scheme_rational_type, "<fractional-number>");
176 set_name(scheme_complex_type, "<complex-number>");
177 set_name(scheme_struct_type_type, "<struct-type>");
178 set_name(scheme_listener_type, "<tcp-listener>");
179 set_name(scheme_tcp_accept_evt_type, "<tcp-accept-evt>");
180 set_name(scheme_filesystem_change_evt_type, "<filesystem-change-evt>");
181 set_name(scheme_env_type, "<env>");
182 set_name(scheme_config_type, "<parameterization>");
183 set_name(scheme_will_executor_type, "<will-executor>");
184 set_name(scheme_random_state_type, "<pseudo-random-generator>");
185 set_name(scheme_regexp_type, "<regexp>");
186 set_name(scheme_bucket_type, "<hash-table-bucket>");
187 set_name(scheme_prefix_type, "<runtime-prefix>");
188 set_name(scheme_readtable_type, "<readtable>");
189
190 set_name(scheme_svector_type, "<short-vector>");
191
192 set_name(scheme_custodian_type, "<custodian>");
193 set_name(scheme_cust_box_type, "<custodian-box>");
194 set_name(scheme_plumber_type, "<plumber>");
195 set_name(scheme_plumber_handle_type, "<plumber-flush-handle>");
196 set_name(scheme_cont_mark_set_type, "<continuation-mark-set>");
197 set_name(scheme_cont_mark_chain_type, "<chain>");
198
199 set_name(scheme_inspector_type, "<inspector>");
200
201 set_name(scheme_stx_type, "<correlated>");
202
203 set_name(scheme_subprocess_type, "<subprocess>");
204
205 set_name(scheme_cpointer_type, "<cpointer>");
206
207 set_name(scheme_security_guard_type, "<security-guard>");
208
209 set_name(scheme_indent_type, "<internal-indentation>");
210
211 set_name(scheme_udp_type, "<udp-socket>");
212 set_name(scheme_udp_evt_type, "<udp-socket-evt>");
213
214 set_name(scheme_evt_set_type, "<evt-set>");
215 set_name(scheme_wrap_evt_type, "<evt>");
216 set_name(scheme_handle_evt_type, "<evt>");
217 set_name(scheme_replace_evt_type, "<evt>");
218 set_name(scheme_nack_evt_type, "<evt>");
219 set_name(scheme_nack_guard_evt_type, "<evt>");
220 set_name(scheme_poll_evt_type, "<evt>");
221 set_name(scheme_semaphore_repost_type, "<semaphore-peek>");
222 set_name(scheme_alarm_type, "<alarm-evt>");
223 set_name(scheme_progress_evt_type, "<progress-evt>");
224 set_name(scheme_write_evt_type, "<write-evt>");
225 set_name(scheme_always_evt_type, "<always-evt>");
226 set_name(scheme_never_evt_type, "<never-evt>");
227 set_name(scheme_thread_recv_evt_type, "<thread-receive-evt>");
228 set_name(scheme_port_closed_evt_type, "<port-closed-evt>");
229
230 set_name(scheme_thread_resume_type, "<thread-resume-evt>");
231 set_name(scheme_thread_suspend_type, "<thread-suspend-evt>");
232 set_name(scheme_thread_dead_type, "<thread-dead-evt>");
233
234 set_name(scheme_thread_set_type, "<thread-set>");
235 set_name(scheme_thread_cell_type, "<thread-cell>");
236 set_name(scheme_thread_cell_values_type, "<thread-cell-values>");
237
238 set_name(scheme_prompt_tag_type, "<continuation-prompt-tag>");
239 set_name(scheme_continuation_mark_key_type, "<continuation-mark-key>");
240
241 set_name(scheme_string_converter_type, "<string-converter>");
242
243 set_name(scheme_channel_syncer_type, "<channel-syncer>");
244
245 set_name(scheme_global_ref_type, "<variable-reference>");
246
247 set_name(scheme_delay_syntax_type, "<on-demand-stub>");
248
249 set_name(scheme_logger_type, "<logger>");
250 set_name(scheme_log_reader_type, "<log-receiver>");
251
252 set_name(scheme_future_type, "<future>");
253 set_name(scheme_fsemaphore_type, "<fsemaphore>");
254
255 set_name(_scheme_values_types_, "<resurrected>");
256 set_name(_scheme_ir_values_types_, "<internal>");
257
258 set_name(scheme_place_type, "<place>");
259 set_name(scheme_place_async_channel_type, "<place-half-channel>");
260 set_name(scheme_place_bi_channel_type, "<place-channel>");
261 set_name(scheme_place_dead_type, "<place-dead-evt>");
262
263 set_name(scheme_phantom_bytes_type, "<phantom-bytes>");
264
265 set_name(scheme_environment_variables_type, "<environment-variables>");
266
267 set_name(scheme_prompt_type, "<prompt>");
268 set_name(scheme_startup_env_type, "<startup-env>");
269 set_name(scheme_ctype_type, "<ctype>");
270
271 set_name(scheme_unquoted_printing_string_type, "<unquoted-printing-string>");
272
273 set_name(scheme_thunk_for_continue_type, "<thunk-for-continue>");
274
275 #ifdef MZ_PRECISE_GC
276 set_name(scheme_rt_runstack, "<runstack>");
277 set_name(scheme_rt_meta_cont, "<meta-continuation>");
278 set_name(scheme_rt_weak_array, "<weak-array>");
279 set_name(scheme_rt_resolve_info, "<compile-resolve-frame>");
280 set_name(scheme_rt_unresolve_info, "<compile-unresolve-frame>");
281 set_name(scheme_rt_optimize_info, "<compile-optimize-frame>");
282 set_name(scheme_rt_ir_lambda_info, "<compile-lambda-info>");
283 set_name(scheme_deferred_expr_type, "<compile-letrec-check-deferred>");
284 set_name(scheme_will_be_lambda_type, "<compile-letrec-check-lambda>");
285 set_name(scheme_rt_indexed_string, "<string-port-data>");
286 set_name(scheme_rt_srcloc, "<srcloc>");
287 set_name(scheme_rt_comp_prefix, "<compile-prefix>");
288 set_name(scheme_rt_native_code, "<native-code>");
289 set_name(scheme_rt_native_code_plus_case, "<native-code+case>");
290 set_name(scheme_rt_sfs_info, "<compile-safe-for-space-frame>");
291 set_name(scheme_rt_letrec_check_frame, "<compile-letrec-check-frame>");
292 set_name(scheme_rt_saved_stack, "<saved-stack>");
293 set_name(scheme_rt_overflow_jmp, "<overflow-jump>");
294 set_name(scheme_rt_dyn_wind, "<dynamic-wind>");
295 set_name(scheme_rt_dyn_wind_info, "<dynamic-wind-info>");
296 set_name(scheme_rt_dyn_wind_cell, "<dynamic-wind-cell>");
297 set_name(scheme_rt_input_fd, "<input-fd>");
298 set_name(scheme_rt_pipe, "<pipe>");
299 set_name(scheme_rt_param_data, "<param-data>");
300 set_name(scheme_rt_will, "<will>");
301 set_name(scheme_rt_finalization, "<finalization>");
302 set_name(scheme_rt_finalizations, "<finalizations>");
303 set_name(scheme_thread_hop_type, "<thread-hop>");
304 set_name(scheme_rt_evt, "<internal-evt>");
305 set_name(scheme_rt_syncing, "<syncing-evt>");
306 set_name(scheme_rt_user_input, "<user-input>");
307 set_name(scheme_rt_user_output, "<user-output>");
308 set_name(scheme_rt_compact_port, "<compact-port>");
309 set_name(scheme_rt_rx_lazy_string, "<rx-lazy-string>");
310 set_name(scheme_rt_parameterization, "<internal-parameterization>");
311 set_name(scheme_rt_delay_load_info, "<delay-load-info>");
312 set_name(scheme_rt_validate_clearing, "<validate-clearing>");
313 set_name(scheme_rt_print_params, "<print-params>");
314 set_name(scheme_rt_comp_env, "<compiler-env>");
315 #endif
316 }
317
scheme_make_type(const char * name)318 Scheme_Type scheme_make_type(const char *name)
319 {
320 Scheme_Type newtype;
321
322 if (!type_names)
323 init_type_arrays();
324
325 #ifdef MZ_USE_PLACES
326 mzrt_mutex_lock(type_array_mutex);
327 #endif
328
329 if (maxtype == allocmax) {
330 /* Expand arrays */
331 void *naya;
332 intptr_t n;
333
334 allocmax += 20;
335
336 naya = malloc(allocmax * sizeof(char *));
337 memcpy(naya, type_names, maxtype * sizeof(char *));
338 memset(naya, 0, maxtype * sizeof(char *));
339 free(type_names);
340 type_names = (char **)naya;
341
342 naya = malloc(n = allocmax * sizeof(Scheme_Equal_Proc));
343 memset(naya, 0, n);
344 memcpy(naya, scheme_type_equals, maxtype * sizeof(Scheme_Equal_Proc));
345 free(scheme_type_equals);
346 scheme_type_equals = (Scheme_Equal_Proc *)naya;
347
348 naya = malloc(n = allocmax * sizeof(Scheme_Primary_Hash_Proc));
349 memset(naya, 0, n);
350 memcpy(naya, scheme_type_hash1s, maxtype * sizeof(Scheme_Primary_Hash_Proc));
351 free(scheme_type_hash1s);
352 scheme_type_hash1s = (Scheme_Primary_Hash_Proc *)naya;
353
354 naya = malloc(n = allocmax * sizeof(Scheme_Secondary_Hash_Proc));
355 memset(naya, 0, n);
356 memcpy(naya, scheme_type_hash2s, maxtype * sizeof(Scheme_Secondary_Hash_Proc));
357 free(scheme_type_hash2s);
358 scheme_type_hash2s = (Scheme_Secondary_Hash_Proc *)naya;
359
360 #ifdef MEMORY_COUNTING_ON
361 scheme_misc_count += (20 * sizeof(char *));
362 #endif
363 }
364
365 {
366 char *tn;
367 int len;
368 len = strlen(name) + 1;
369 tn = (char *)malloc(len);
370 memcpy(tn, name, len);
371 type_names[maxtype] = tn;
372 }
373
374 newtype = maxtype;
375 maxtype++;
376
377 #ifdef MZ_USE_PLACES
378 mzrt_mutex_unlock(type_array_mutex);
379 #endif
380
381 return newtype;
382 }
383
scheme_get_type_name_or_null(Scheme_Type t)384 char *scheme_get_type_name_or_null(Scheme_Type t)
385 {
386 if (t < 0 || t >= maxtype)
387 return "<bad-value>";
388 return type_names[t];
389 }
390
scheme_get_type_name(Scheme_Type t)391 char *scheme_get_type_name(Scheme_Type t)
392 {
393 char *s;
394 s = scheme_get_type_name_or_null(t);
395 return s ? s : "???";
396 }
397
scheme_set_type_equality(Scheme_Type t,Scheme_Equal_Proc f,Scheme_Primary_Hash_Proc hash1,Scheme_Secondary_Hash_Proc hash2)398 void scheme_set_type_equality(Scheme_Type t,
399 Scheme_Equal_Proc f,
400 Scheme_Primary_Hash_Proc hash1,
401 Scheme_Secondary_Hash_Proc hash2)
402 {
403 if (t < 0 || t >= maxtype)
404 return;
405
406 scheme_type_equals[t] = f;
407 scheme_type_hash1s[t] = hash1;
408 scheme_type_hash2s[t] = hash2;
409 }
410
scheme_num_types(void)411 int scheme_num_types(void)
412 {
413 return maxtype;
414 }
415
416 /***********************************************************************/
417
418 #ifdef MZ_PRECISE_GC
419
420 START_XFORM_SKIP;
421
bad_trav_SIZE(void * p,struct NewGC * gc)422 static int bad_trav_SIZE(void *p, struct NewGC *gc)
423 {
424 printf("Shouldn't get here.\n");
425 exit(1);
426 }
427
bad_trav_MARK(void * p,struct NewGC * gc)428 static int bad_trav_MARK(void *p, struct NewGC *gc)
429 {
430 printf("Shouldn't get here.\n");
431 exit(1);
432 }
433
bad_trav_FIXUP(void * p,struct NewGC * gc)434 static int bad_trav_FIXUP(void *p, struct NewGC *gc)
435 {
436 printf("Shouldn't get here.\n");
437 exit(1);
438 }
439
440 #define bad_trav_IS_CONST_SIZE 0
441 #define bad_trav_IS_ATOMIC 0
442
MARK_cjs(Scheme_Continuation_Jump_State * cjs,struct NewGC * gc)443 static void MARK_cjs(Scheme_Continuation_Jump_State *cjs, struct NewGC *gc)
444 {
445 gcMARK2(cjs->jumping_to_continuation, gc);
446 gcMARK2(cjs->alt_full_continuation, gc);
447 gcMARK2(cjs->val, gc);
448 }
449
FIXUP_cjs(Scheme_Continuation_Jump_State * cjs,struct NewGC * gc)450 static void FIXUP_cjs(Scheme_Continuation_Jump_State *cjs, struct NewGC *gc)
451 {
452 gcFIXUP2(cjs->jumping_to_continuation, gc);
453 gcFIXUP2(cjs->alt_full_continuation, gc);
454 gcFIXUP2(cjs->val, gc);
455 }
456
MARK_stack_state(Scheme_Stack_State * ss,struct NewGC * gc)457 static void MARK_stack_state(Scheme_Stack_State *ss, struct NewGC *gc)
458 {
459 }
460
FIXUP_stack_state(Scheme_Stack_State * ss,struct NewGC * gc)461 static void FIXUP_stack_state(Scheme_Stack_State *ss, struct NewGC *gc)
462 {
463 }
464
MARK_jmpup(Scheme_Jumpup_Buf * buf,struct NewGC * gc)465 static void MARK_jmpup(Scheme_Jumpup_Buf *buf, struct NewGC *gc)
466 {
467 gcMARK2(buf->stack_copy, gc);
468 gcMARK2(buf->cont, gc);
469 gcMARK2(buf->external_stack, gc);
470
471 /* IMPORTANT: the buf->stack_copy pointer must be the only instance
472 of this stack to be traversed. If you copy a jmpup buffer (as in
473 fun.c), don't let a GC happen until the old copy is zeroed
474 out. */
475 if (buf->stack_copy)
476 GC_mark2_variable_stack(buf->gc_var_stack,
477 (intptr_t)buf->stack_copy - (intptr_t)buf->stack_from,
478 /* FIXME: stack direction */
479 (char *)buf->stack_copy + buf->stack_size,
480 buf->stack_copy,
481 gc);
482 }
483
FIXUP_jmpup(Scheme_Jumpup_Buf * buf,struct NewGC * gc)484 static void FIXUP_jmpup(Scheme_Jumpup_Buf *buf, struct NewGC *gc)
485 {
486 void *new_stack;
487
488 new_stack = GC_resolve(buf->stack_copy);
489 gcFIXUP2_TYPED_NOW(void *, buf->stack_copy, gc);
490 gcFIXUP2(buf->cont, gc);
491 gcFIXUP2(buf->external_stack, gc);
492
493 if (buf->stack_copy)
494 GC_fixup2_variable_stack(buf->gc_var_stack,
495 (intptr_t)new_stack - (intptr_t)buf->stack_from,
496 /* FIXME: stack direction */
497 (char *)new_stack + buf->stack_size,
498 new_stack,
499 gc);
500 }
501
502 #define RUNSTACK_ZERO_VAL NULL
503
504 #include "mzmark_type.inc"
505
scheme_register_traversers(void)506 void scheme_register_traversers(void)
507 {
508 GC_REG_TRAV(scheme_toplevel_type, toplevel_obj);
509 GC_REG_TRAV(scheme_static_toplevel_type, static_toplevel_obj);
510 GC_REG_TRAV(scheme_variable_type, variable_obj);
511 GC_REG_TRAV(scheme_local_type, local_obj);
512 GC_REG_TRAV(scheme_local_unbox_type, local_obj);
513 GC_REG_TRAV(scheme_application_type, app_rec);
514 GC_REG_TRAV(scheme_application2_type, app2_rec);
515 GC_REG_TRAV(scheme_application3_type, app3_rec);
516 GC_REG_TRAV(scheme_sequence_type, seq_rec);
517 GC_REG_TRAV(scheme_branch_type, branch_rec);
518 GC_REG_TRAV(scheme_lambda_type, unclosed_proc);
519 GC_REG_TRAV(scheme_let_value_type, let_value);
520 GC_REG_TRAV(scheme_let_void_type, let_void);
521 GC_REG_TRAV(scheme_letrec_type, letrec);
522 GC_REG_TRAV(scheme_let_one_type, let_one);
523 GC_REG_TRAV(scheme_with_cont_mark_type, with_cont_mark);
524
525 GC_REG_TRAV(scheme_define_values_type, vector_obj);
526 GC_REG_TRAV(scheme_varref_form_type, twoptr_obj);
527 GC_REG_TRAV(scheme_apply_values_type, twoptr_obj);
528 GC_REG_TRAV(scheme_with_immed_mark_type, with_cont_mark);
529 GC_REG_TRAV(scheme_boxenv_type, twoptr_obj);
530 GC_REG_TRAV(scheme_case_lambda_sequence_type, case_closure);
531 GC_REG_TRAV(scheme_begin0_sequence_type, seq_rec);
532 GC_REG_TRAV(scheme_set_bang_type, set_bang);
533 GC_REG_TRAV(scheme_inline_variant_type, vector_obj);
534
535 GC_REG_TRAV(_scheme_values_types_, bad_trav);
536
537 GC_REG_TRAV(scheme_ir_lambda_type, unclosed_proc);
538 GC_REG_TRAV(scheme_ir_local_type, ir_local);
539 GC_REG_TRAV(scheme_ir_toplevel_type, ir_toplevel);
540 GC_REG_TRAV(scheme_ir_let_value_type, ir_let_value);
541 GC_REG_TRAV(scheme_ir_let_header_type, let_header);
542
543 GC_REG_TRAV(scheme_quote_compilation_type, small_object);
544
545 GC_REG_TRAV(scheme_linklet_type, linklet_val);
546 GC_REG_TRAV(scheme_instance_type, instance_val);
547 GC_REG_TRAV(scheme_linklet_bundle_type, small_object);
548
549 GC_REG_TRAV(_scheme_ir_values_types_, bad_trav);
550
551 GC_REG_TRAV(scheme_prefix_type, prefix_val);
552
553 GC_REG_TRAV(scheme_prim_type, prim_proc);
554 GC_REG_TRAV(scheme_closed_prim_type, closed_prim_proc);
555 GC_REG_TRAV(scheme_closure_type, scm_closure);
556 GC_REG_TRAV(scheme_case_closure_type, case_closure);
557 GC_REG_TRAV(scheme_cont_type, cont_proc);
558 GC_REG_TRAV(scheme_rt_dyn_wind, mark_dyn_wind);
559 GC_REG_TRAV(scheme_rt_overflow, mark_overflow);
560 GC_REG_TRAV(scheme_rt_overflow_jmp, mark_overflow_jmp);
561 GC_REG_TRAV(scheme_rt_meta_cont, meta_cont_proc);
562 GC_REG_TRAV(scheme_escaping_cont_type, escaping_cont_proc);
563 GC_REG_TRAV(scheme_rt_cont_jmp, cont_jmp_proc);
564
565 GC_REG_TRAV(scheme_char_type, small_atomic_obj);
566 GC_REG_TRAV(scheme_integer_type, bad_trav);
567 GC_REG_TRAV(scheme_bignum_type, bignum_obj);
568 GC_REG_TRAV(scheme_rational_type, rational_obj);
569 GC_REG_TRAV(scheme_float_type, float_obj);
570 GC_REG_TRAV(scheme_double_type, double_obj);
571 GC_REG_TRAV(scheme_long_double_type, long_double_obj);
572 GC_REG_TRAV(scheme_complex_type, complex_obj);
573 GC_REG_TRAV(scheme_char_string_type, string_obj);
574 GC_REG_TRAV(scheme_byte_string_type, bstring_obj);
575 GC_REG_TRAV(scheme_unix_path_type, bstring_obj);
576 GC_REG_TRAV(scheme_windows_path_type, bstring_obj);
577 GC_REG_TRAV(scheme_symbol_type, symbol_obj);
578 #ifdef MZ_USE_PLACES
579 GC_REG_TRAV(scheme_serialized_symbol_type, bstring_obj);
580 GC_REG_TRAV(scheme_serialized_keyword_type, bstring_obj);
581 GC_REG_TRAV(scheme_place_dead_type, small_object);
582 #endif
583 GC_REG_TRAV(scheme_keyword_type, symbol_obj);
584 GC_REG_TRAV(scheme_null_type, small_atomic_obj);
585 GC_REG_TRAV(scheme_pair_type, cons_cell);
586 GC_REG_TRAV(scheme_mutable_pair_type, cons_cell);
587 GC_REG_TRAV(scheme_raw_pair_type, cons_cell);
588 GC_REG_TRAV(scheme_vector_type, vector_obj);
589 GC_REG_TRAV(scheme_flvector_type, flvector_obj);
590 #ifdef MZ_LONG_DOUBLE
591 GC_REG_TRAV(scheme_extflvector_type, extflvector_obj);
592 #endif
593 GC_REG_TRAV(scheme_fxvector_type, fxvector_obj);
594 GC_REG_TRAV(scheme_cpointer_type, cpointer_obj);
595
596 GC_REG_TRAV(scheme_bucket_type, bucket_obj);
597
598 GC_REG_TRAV(scheme_input_port_type, input_port);
599 GC_REG_TRAV(scheme_output_port_type, output_port);
600 GC_REG_TRAV(scheme_eof_type, small_atomic_obj);
601 GC_REG_TRAV(scheme_true_type, small_atomic_obj);
602 GC_REG_TRAV(scheme_false_type, small_atomic_obj);
603 GC_REG_TRAV(scheme_void_type, small_atomic_obj);
604 GC_REG_TRAV(scheme_box_type, small_object);
605 GC_REG_TRAV(scheme_thread_type, thread_val);
606 GC_REG_TRAV(scheme_prompt_type, prompt_val);
607 GC_REG_TRAV(scheme_prompt_tag_type, cons_cell);
608 GC_REG_TRAV(scheme_continuation_mark_key_type, small_object);
609 GC_REG_TRAV(scheme_cont_mark_set_type, cont_mark_set_val);
610 GC_REG_TRAV(scheme_sema_type, sema_val);
611 GC_REG_TRAV(scheme_channel_type, channel_val);
612 GC_REG_TRAV(scheme_channel_put_type, channel_put_val);
613 GC_REG_TRAV(scheme_semaphore_repost_type, small_object);
614 GC_REG_TRAV(scheme_thread_suspend_type, twoptr_obj);
615 GC_REG_TRAV(scheme_thread_resume_type, twoptr_obj);
616 GC_REG_TRAV(scheme_thread_dead_type, small_object);
617 GC_REG_TRAV(scheme_hash_table_type, hash_table_val);
618 GC_REG_TRAV(scheme_bucket_table_type, bucket_table_val);
619 GC_REG_TRAV(scheme_env_type, env_val);
620 GC_REG_TRAV(scheme_startup_env_type, startup_env_val);
621 GC_REG_TRAV(scheme_random_state_type, random_state_val);
622
623 GC_REG_TRAV(scheme_eval_waiting_type, bad_trav);
624 GC_REG_TRAV(scheme_tail_call_waiting_type, bad_trav);
625 GC_REG_TRAV(scheme_undefined_type, small_atomic_obj);
626 GC_REG_TRAV(scheme_placeholder_type, small_object);
627 GC_REG_TRAV(scheme_table_placeholder_type, iptr_obj);
628
629 GC_REG_TRAV(scheme_svector_type, svector_val);
630
631 GC_REG_TRAV(scheme_stx_type, stx_val);
632
633 GC_REG_TRAV(scheme_security_guard_type, guard_val);
634
635 GC_REG_TRAV(scheme_nack_evt_type, twoptr_obj);
636 GC_REG_TRAV(scheme_always_evt_type, small_atomic_obj);
637 GC_REG_TRAV(scheme_never_evt_type, small_atomic_obj);
638 GC_REG_TRAV(scheme_thread_recv_evt_type, small_atomic_obj);
639 GC_REG_TRAV(scheme_port_closed_evt_type, small_object);
640
641 GC_REG_TRAV(scheme_inspector_type, mark_inspector);
642
643 GC_REG_TRAV(scheme_rt_buf_holder, buf_holder);
644 GC_REG_TRAV(scheme_rt_pipe, mark_pipe);
645
646 GC_REG_TRAV(scheme_tcp_accept_evt_type, twoptr_obj);
647
648 GC_REG_TRAV(scheme_progress_evt_type, twoptr_obj);
649
650 GC_REG_TRAV(scheme_will_be_lambda_type, iptr_obj);
651
652 GC_REG_TRAV(scheme_thread_cell_values_type, small_object);
653
654 GC_REG_TRAV(scheme_thunk_for_continue_type, small_object);
655
656 GC_REG_TRAV(scheme_global_ref_type, twoptr_obj);
657
658 GC_REG_TRAV(scheme_delay_syntax_type, small_object);
659
660 GC_REG_TRAV(scheme_logger_type, mark_logger);
661 GC_REG_TRAV(scheme_log_reader_type, mark_log_reader);
662
663 GC_REG_TRAV(scheme_rt_runstack, runstack_val);
664
665 GC_REG_TRAV(scheme_noninline_proc_type, small_object);
666
667 GC_REG_TRAV(scheme_proc_shape_type, small_atomic_obj);
668 GC_REG_TRAV(scheme_struct_proc_shape_type, struct_proc_shape);
669 GC_REG_TRAV(scheme_struct_prop_proc_shape_type, small_atomic_obj);
670
671 GC_REG_TRAV(scheme_environment_variables_type, small_object);
672
673 GC_REG_TRAV(scheme_plumber_handle_type, twoptr_obj);
674
675 GC_REG_TRAV(scheme_unquoted_printing_string_type, small_object);
676 }
677
678 END_XFORM_SKIP;
679
680 #endif
681
682 /***********************************************************************/
683
684 #ifdef MZ_PRECISE_GC
685
686 /* A shape string is a SCHEME_GC_SHAPE_TERM-terminated array of `intptr_t`s,
687 where each instruction is followed by a value. For now, the only
688 required instructions are SCHEME_GC_SHAPE_PTR_OFFSET, but other values
689 are tolerated and ignored for future extensions in case they become
690 necessary. */
691
692 static int shape_str_array_size = 0;
693 static intptr_t **shape_strs = NULL;
694
695 START_XFORM_SKIP;
696
shape_size(void * p,struct NewGC * gc)697 static int shape_size(void *p, struct NewGC *gc) {
698 #ifndef GC_NO_SIZE_NEEDED_FROM_PROCS
699 intptr_t *shape_str = shape_strs[*(Scheme_Type *)p];
700 int sz = 0;
701 while (*shape_str != SCHEME_GC_SHAPE_TERM) {
702 if (shape_str[0] == SCHEME_GC_SHAPE_ADD_SIZE)
703 sz += shape_str[1];
704 shape_str += 2;
705 }
706 #else
707 return 0;
708 #endif
709 }
710
shape_mark(void * p,struct NewGC * gc)711 static int shape_mark(void *p, struct NewGC *gc) {
712 #ifndef GC_NO_MARK_PROCEDURE_NEEDED
713 intptr_t *shape_str = shape_strs[*(Scheme_Type *)p];
714
715 while (*shape_str != SCHEME_GC_SHAPE_TERM) {
716 if (shape_str[0] == SCHEME_GC_SHAPE_PTR_OFFSET) {
717 gcMARK2(*(void **)((char *)p + shape_str[1]), gc);
718 }
719 shape_str += 2;
720 }
721
722 # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS
723 return 0;
724 # else
725 return shape_size(p, gc);
726 # endif
727 #endif
728 }
729
shape_fixup(void * p,struct NewGC * gc)730 static int shape_fixup(void *p, struct NewGC *gc) {
731 #ifndef GC_NO_FIXUP_PROCEDURE_NEEDED
732 intptr_t *shape_str = shape_strs[*(Scheme_Type *)p];
733
734 while (*shape_str != SCHEME_GC_SHAPE_TERM) {
735 if (shape_str[0] == SCHEME_GC_SHAPE_PTR_OFFSET) {
736 gcFIXUP2(*(void **)((char *)p + shape_str[1]), gc);
737 }
738 shape_str += 2;
739 }
740
741 # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS
742 return 0;
743 # else
744 return shape_size(p, gc);
745 # endif
746 #endif
747 }
748
749 END_XFORM_SKIP;
750
scheme_register_type_gc_shape(Scheme_Type type,intptr_t * shape_str)751 void scheme_register_type_gc_shape(Scheme_Type type, intptr_t *shape_str)
752 {
753 intptr_t len;
754 GC_CAN_IGNORE intptr_t *str;
755
756 for (len = 0; shape_str[len] != SCHEME_GC_SHAPE_TERM; len += 2) {
757 }
758 len++;
759
760 str = (intptr_t *)malloc(len * sizeof(intptr_t));
761 memcpy(str, shape_str, len * sizeof(intptr_t));
762
763 scheme_process_global_lock();
764
765 if (shape_str_array_size <= type) {
766 GC_CAN_IGNORE intptr_t **naya;
767 int sz = 2 * (type + 1);
768 naya = malloc(sz * sizeof(intptr_t *));
769 memset(naya, 0, sz * sizeof(intptr_t *));
770 if (shape_str_array_size) {
771 memcpy(naya, shape_strs, sizeof(intptr_t *) * shape_str_array_size);
772 free(shape_strs);
773 }
774 shape_strs = naya;
775 shape_str_array_size = sz;
776 }
777
778 if (shape_strs[type])
779 free(shape_strs[type]);
780 shape_strs[type] = str;
781
782 scheme_process_global_unlock();
783
784 GC_register_traversers2(type, shape_size, shape_mark, shape_fixup, 1, 0);
785 }
786
787 #else
788
scheme_register_type_gc_shape(Scheme_Type type,intptr_t * shape_str)789 void scheme_register_type_gc_shape(Scheme_Type type, intptr_t *shape_str)
790 {
791
792 }
793
794 #endif
795