1 /* 2 Racket prototypes and declarations for internal consumption. 3 */ 4 5 #ifndef __mzscheme_private__ 6 #define __mzscheme_private__ 7 8 // #define MZ_GC_STRESS_TESTING 1 9 10 #include "scheme.h" 11 #include "longdouble/longdouble.h" 12 13 #ifdef CIL_ANALYSIS 14 #define ROSYM __attribute__((__ROSYM__)) 15 #define READ_ONLY __attribute__((__READ_ONLY__)) 16 #define SHARED_OK __attribute__((__SHARED_OK__)) 17 #define HOOK_SHARED_OK __attribute__((__HOOK_SHARED_OK__)) 18 #else 19 #define ROSYM /* EMPTY */ 20 #define READ_ONLY /* EMPTY */ 21 #define SHARED_OK /* EMPTY */ 22 #define HOOK_SHARED_OK /* EMPTY */ 23 #endif 24 25 #if defined(OS_X) || defined(__linux__) 26 # define MZ_CHECK_ASSERTS 27 #endif 28 29 #ifdef MZ_CHECK_ASSERTS 30 # include <assert.h> 31 # define MZ_ASSERT(x) assert(x) 32 #else 33 # define MZ_ASSERT(x) /* empty */ 34 #endif 35 36 /*========================================================================*/ 37 /* optimization flags */ 38 /*========================================================================*/ 39 40 /* Used with SCHEME_LOCAL_TYPE_MASK, LET_ONE_TYPE_MASK, etc.*/ 41 #define SCHEME_LOCAL_TYPE_FLONUM 1 42 #define SCHEME_LOCAL_TYPE_FIXNUM 2 43 #define SCHEME_LOCAL_TYPE_EXTFLONUM 3 44 45 #define SCHEME_MAX_LOCAL_TYPE 3 46 47 #define SCHEME_MAX_LOCAL_TYPE_MASK 0x3 48 #define SCHEME_MAX_LOCAL_TYPE_BITS 2 49 50 /* Flonum unboxing is only useful if a value is going to flow to a 51 function that wants it, otherwise we'll have to box the flonum anyway. 52 Also, we can only leave flonums unboxed if they don't escape 53 before a potential continuation capture. 54 Fixnum unboxing is always fine, since it's easy to box and doesn't 55 involve allocation. */ 56 #define ALWAYS_PREFER_UNBOX_TYPE(ty) ((ty) == SCHEME_LOCAL_TYPE_FIXNUM) 57 58 #define IN_FIXNUM_RANGE_ON_ALL_PLATFORMS(v) (((v) >= -1073741824) && ((v) <= 1073741823)) 59 60 #define MOST_POSITIVE_FIXNUM (((uintptr_t)-1) >> 2) 61 #define MOST_NEGATIVE_FIXNUM ((((uintptr_t)-1) >> 1) ^ (((uintptr_t)-1) >> 2)) 62 63 /* We support 2^SCHEME_PRIM_OPT_INDEX_SIZE combinations of optimization flags: */ 64 65 /* marks a primitive as JIT-inlined for 1 argument: */ 66 #define SCHEME_PRIM_IS_UNARY_INLINED (1 << 0) 67 /* marks a primitive as JIT-inlined for 2 arguments: */ 68 #define SCHEME_PRIM_IS_BINARY_INLINED (1 << 1) 69 /* marks a primitive as JIT-inlined for 0 or 3+ arguments: */ 70 #define SCHEME_PRIM_IS_NARY_INLINED (1 << 2) 71 /* indicates that a primitive call can be dropped if it's result is not used; 72 although the function never raises an exception, it should not be reordered 73 past a test that might be a guard or past an expression that might 74 have a side effect: */ 75 #define SCHEME_PRIM_IS_UNSAFE_OMITABLE (1 << 3) 76 /* indicates that a primitive call can be dropped if it's result is not used, 77 because it has no side-effect and never raises an exception: */ 78 #define SCHEME_PRIM_IS_OMITABLE (1 << 4) 79 /* indicates that a primitive call can be dropped, but it allocates, 80 so it's not as reorderable as it might be otherwise: */ 81 #define SCHEME_PRIM_IS_OMITABLE_ALLOCATION (1 << 5) 82 #define SCHEME_PRIM_IS_ARITY_0_OMITABLE_ALLOCATION (1 << 6) 83 #define SCHEME_PRIM_IS_EVEN_ARITY_OMITABLE_ALLOCATION (1 << 7) 84 /* indicates that a primitive call will produce the same results for the same 85 inputs; note that UNSAFE_FUNCTIONAL is stronger than UNSAFE_OMITABLE: */ 86 #define SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL (1 << 8) 87 /* the SCHEME_PRIMT_WANTS_... flags indicate a primitive that 88 expects certain kinds of arguments and can encourage unboxing: */ 89 #define SCHEME_PRIM_WANTS_FLONUM_FIRST (1 << 9) 90 #define SCHEME_PRIM_WANTS_FLONUM_SECOND (1 << 10) 91 #define SCHEME_PRIM_WANTS_FLONUM_THIRD (1 << 11) 92 #define SCHEME_PRIM_WANTS_EXTFLONUM_FIRST (1 << 12) 93 #define SCHEME_PRIM_WANTS_EXTFLONUM_SECOND (1 << 13) 94 #define SCHEME_PRIM_WANTS_EXTFLONUM_THIRD (1 << 14) 95 /* indicates an unsafe operation that does not allocate: */ 96 #define SCHEME_PRIM_IS_UNSAFE_NONALLOCATE (1 << 15) 97 /* indicates a primitive that always raises an exception or 98 otherwise escapes from the current continuation: */ 99 #define SCHEME_PRIM_ALWAYS_ESCAPES (1 << 16) 100 /* indicates a primitive that is JIT-inlined on some platforms, 101 but not the current one: */ 102 #define SCHEME_PRIM_SOMETIMES_INLINED (1 << 17) 103 /* indicates a primitive that produces a real or number (or 104 errors): */ 105 #define SCHEME_PRIM_PRODUCES_REAL (1 << 18) 106 #define SCHEME_PRIM_PRODUCES_NUMBER (1 << 19) 107 /* indicates a primitive that requires certain argument types (all the 108 same type): */ 109 #define SCHEME_PRIM_WANTS_REAL (1 << 20) 110 #define SCHEME_PRIM_WANTS_NUMBER (1 << 21) 111 /* indicates a primitive that always succeed when given 112 arguments of the expected type: */ 113 #define SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS (1 << 22) 114 /* indicates a primitive that produces a real number when 115 given real-number arguments: */ 116 #define SCHEME_PRIM_CLOSED_ON_REALS (1 << 23) 117 /* indicates the presence of an ad-hoc optimization 118 in one of the application optimization passes */ 119 #define SCHEME_PRIM_AD_HOC_OPT (1 << 24) 120 /* a primitive that produces a booeal or errors: */ 121 #define SCHEME_PRIM_PRODUCES_BOOL (1 << 25) 122 123 #define SCHEME_PRIM_OPT_TYPE_SHIFT 26 124 #define SCHEME_PRIM_OPT_TYPE_MASK (SCHEME_MAX_LOCAL_TYPE_MASK << SCHEME_PRIM_OPT_TYPE_SHIFT) 125 #define SCHEME_PRIM_OPT_TYPE(x) ((x & SCHEME_PRIM_OPT_TYPE_MASK) >> SCHEME_PRIM_OPT_TYPE_SHIFT) 126 127 #define SCHEME_PRIM_PRODUCES_FLONUM (SCHEME_LOCAL_TYPE_FLONUM << SCHEME_PRIM_OPT_TYPE_SHIFT) 128 #define SCHEME_PRIM_PRODUCES_FIXNUM (SCHEME_LOCAL_TYPE_FIXNUM << SCHEME_PRIM_OPT_TYPE_SHIFT) 129 130 #define SCHEME_PRIM_WANTS_FLONUM_BOTH (SCHEME_PRIM_WANTS_FLONUM_FIRST | SCHEME_PRIM_WANTS_FLONUM_SECOND) 131 132 #define SCHEME_PRIM_PRODUCES_EXTFLONUM (SCHEME_LOCAL_TYPE_EXTFLONUM << SCHEME_PRIM_OPT_TYPE_SHIFT) 133 #define SCHEME_PRIM_WANTS_EXTFLONUM_BOTH (SCHEME_PRIM_WANTS_EXTFLONUM_FIRST | SCHEME_PRIM_WANTS_EXTFLONUM_SECOND) 134 135 extern int scheme_prim_opt_flags[]; /* uses an index from SCHEME_PRIM_OPT_INDEX_MASK */ 136 extern XFORM_NONGCING int scheme_intern_prim_opt_flags(int); 137 138 #define SCHEME_PRIM_PROC_OPT_FLAGS(proc) \ 139 scheme_prim_opt_flags[(SCHEME_PRIM_PROC_FLAGS(proc) >> SCHEME_PRIM_OPT_INDEX_SHIFT) \ 140 & SCHEME_PRIM_OPT_INDEX_MASK] 141 142 /*========================================================================*/ 143 /* allocation and GC */ 144 /*========================================================================*/ 145 146 #define MAKE_CLOSED_PRIM(f,v,n,mi,ma) \ 147 scheme_make_closed_prim_w_arity((Scheme_Closed_Prim *)f, (void *)v, n, mi, ma) 148 149 #define _MALLOC_N(x, n, malloc) ((x*)malloc(sizeof(x)*(n))) 150 #define MALLOC_ONE(x) _MALLOC_N(x, 1, scheme_malloc) 151 #define MALLOC_ONE_TAGGED(x) _MALLOC_N(x, 1, scheme_malloc_small_tagged) 152 #define MALLOC_N_TAGGED(x, n) _MALLOC_N(x, n, scheme_malloc_array_tagged) 153 #ifdef MZTAG_REQUIRED 154 # define scheme_malloc_rt(x) scheme_malloc_tagged(x) 155 # define MALLOC_ONE_RT(x) MALLOC_ONE_TAGGED(x) 156 # define MALLOC_ONE_WEAK(x) _MALLOC_N(x, 1, scheme_malloc) 157 # define MALLOC_N_WEAK(x,c) _MALLOC_N(x, c, scheme_malloc) 158 # define MALLOC_ONE_TAGGED_WEAK(x) _MALLOC_N(x, 1, scheme_malloc_tagged) 159 # define MALLOC_ONE_WEAK_RT(x) MALLOC_ONE_TAGGED_WEAK(x) 160 #else 161 # define scheme_malloc_rt(x) scheme_malloc(x) 162 # define MALLOC_ONE_RT(x) MALLOC_ONE(x) 163 # define MALLOC_ONE_WEAK(x) MALLOC_ONE_ATOMIC(x) 164 # define MALLOC_N_WEAK(x,c) MALLOC_N_ATOMIC(x,c) 165 # define MALLOC_ONE_WEAK_RT(x) MALLOC_ONE_WEAK(x) 166 # define MALLOC_ONE_TAGGED_WEAK(x) MALLOC_ONE_WEAK(x) 167 #endif 168 #define MALLOC_N(x, n) _MALLOC_N(x, n, scheme_malloc) 169 #define MALLOC_ONE_ATOMIC(x) _MALLOC_N(x, 1, scheme_malloc_atomic) 170 #define MALLOC_N_ATOMIC(x, n) _MALLOC_N(x, n, scheme_malloc_atomic) 171 #define MALLOC_SO_BOX() _MALLOC_ONE(Scheme_Object*, scheme_malloc) 172 #define MALLOC_N_STUBBORN(x, n) _MALLOC_N(x, n, scheme_malloc_stubborn) 173 174 #ifdef MZ_PRECISE_GC 175 # define WEAKIFY(x) scheme_make_weak_box(x) 176 # define WEAKIFIED(x) SCHEME_WEAK_BOX_VAL(x) 177 # define HT_EXTRACT_WEAK(x) SCHEME_WEAK_BOX_VAL(x) 178 #else 179 # define WEAKIFY(x) x 180 # define WEAKIFIED(x) x 181 # define HT_EXTRACT_WEAK(x) (*(char **)(x)) 182 #endif 183 184 #ifndef MZ_XFORM 185 # define START_XFORM_SKIP /**/ 186 # define END_XFORM_SKIP /**/ 187 # define GC_CAN_IGNORE /**/ 188 # define GC_MAYBE_IGNORE_INTERIOR /**/ 189 # define XFORM_OK_PLUS + 190 # define XFORM_OK_MINUS - 191 #else 192 # ifdef GC_INTERIORABLES_NEVER_MOVE 193 # define GC_MAYBE_IGNORE_INTERIOR GC_CAN_IGNORE 194 # else 195 # define GC_MAYBE_IGNORE_INTERIOR /**/ 196 # endif 197 #endif 198 199 #ifdef MZ_PRECISE_GC 200 intptr_t scheme_hash_key(Scheme_Object *o); 201 #else 202 # define scheme_hash_key(o) ((intptr_t)(o)) 203 #endif 204 typedef int (*Compare_Proc)(void *v1, void *v2); 205 206 XFORM_NONGCING void scheme_install_symbol_hash_code(Scheme_Object *sym, uintptr_t h); 207 208 Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[]); 209 210 #define REGISTER_SO(x) MZ_REGISTER_STATIC(x) 211 212 THREAD_LOCAL_DECL(extern struct rktio_t *scheme_rktio); 213 THREAD_LOCAL_DECL(extern int scheme_current_place_id); 214 THREAD_LOCAL_DECL(extern uintptr_t scheme_total_gc_time); 215 THREAD_LOCAL_DECL(extern int scheme_cont_capture_count); 216 THREAD_LOCAL_DECL(extern int scheme_continuation_application_count); 217 THREAD_LOCAL_DECL(extern struct Scheme_Prefix *scheme_prefix_finalize); 218 THREAD_LOCAL_DECL(extern struct Scheme_Prefix *scheme_inc_prefix_finalize); 219 220 int scheme_num_types(void); 221 222 #ifdef MZTAG_REQUIRED 223 # define MZTAG_IF_REQUIRED Scheme_Type type; 224 # define SET_REQUIRED_TAG(e) e 225 #else 226 # define MZTAG_IF_REQUIRED /* empty */ 227 # define SET_REQUIRED_TAG(e) /* empty */ 228 #endif 229 230 #if MZ_USE_NOINLINE 231 # define MZ_DO_NOT_INLINE(decl) decl __attribute__ ((noinline)) 232 #elif _MSC_VER 233 # define MZ_DO_NOT_INLINE(decl) __declspec(noinline) decl 234 #else 235 # define MZ_DO_NOT_INLINE(decl) decl 236 #endif 237 238 239 #define GC_REG_TRAV(type, base) \ 240 GC_register_traversers2(type, base ## _SIZE, base ## _MARK, base ## _FIXUP, base ## _IS_CONST_SIZE, base ## _IS_ATOMIC) 241 242 void scheme_reset_finalizations(void); 243 244 uintptr_t scheme_get_primordial_thread_stack_base(void); 245 uintptr_t scheme_get_current_os_thread_stack_base(void); 246 void scheme_set_current_os_thread_stack_base(void *base); 247 248 #ifdef MZ_PRECISE_GC 249 uintptr_t scheme_get_current_thread_stack_start(void); 250 #endif 251 252 int scheme_propagate_ephemeron_marks(void); 253 void scheme_clear_ephemerons(void); 254 255 #ifndef MZ_XFORM 256 # define HIDE_FROM_XFORM(x) x 257 #endif 258 259 #define mzALIAS (void *) 260 261 #define BITS_PER_MZSHORT (8 * sizeof(mzshort)) 262 263 #ifndef NO_INLINE_KEYWORD 264 # define MZ_INLINE M_MSC_IZE(inline) 265 #else 266 # define MZ_INLINE /* empty */ 267 #endif 268 269 #if _MSC_VER 270 # define MZ_NO_INLINE _declspec(noinline) 271 #elif defined(__GNUC__) 272 # define MZ_NO_INLINE __attribute ((__noinline__)) 273 #else 274 # define MZ_NO_INLINE /* empty */ 275 #endif 276 277 #ifdef MZ_PRECISE_GC 278 # define CLEAR_KEY_FIELD(o) ((o)->keyex = 0) 279 #else 280 # define CLEAR_KEY_FIELD(o) /* empty */ 281 #endif 282 283 #define SCHEME_PAIR_FLAGS(pr) MZ_OPT_HASH_KEY(&((Scheme_Simple_Object *)pr)->iso) 284 #define PAIR_IS_LIST 0x1 285 #define PAIR_IS_NON_LIST 0x2 286 #define PAIR_FLAG_MASK 0x3 287 288 #define SCHEME_PAIR_COPY_FLAGS(dest, src) (SCHEME_PAIR_FLAGS((dest)) |= (SCHEME_PAIR_FLAGS((src)) & PAIR_FLAG_MASK)) 289 290 #ifdef MZ_USE_MAP_JIT 291 XFORM_NONGCING void scheme_thread_code_start_write(void); 292 XFORM_NONGCING void scheme_thread_code_end_write(void); 293 #else 294 # define scheme_thread_code_start_write() do { } while (0) 295 # define scheme_thread_code_end_write() do { } while (0) 296 #endif 297 298 /*========================================================================*/ 299 /* initialization */ 300 /*========================================================================*/ 301 302 THREAD_LOCAL_DECL(extern int scheme_starting_up); 303 304 typedef struct Scheme_Startup_Env Scheme_Startup_Env; 305 306 void scheme_init_finalization(void); 307 void scheme_init_portable_case(void); 308 void scheme_init_stack_check(void); 309 void scheme_init_overflow(void); 310 #ifdef MZ_USE_JIT 311 void scheme_init_jit(void); 312 void scheme_init_jitprep(void); 313 #endif 314 #ifdef MZ_PRECISE_GC 315 void scheme_register_traversers(void); 316 void scheme_init_hash_key_procs(void); 317 #endif 318 Scheme_Thread *scheme_make_thread(void*); 319 void scheme_init_process_globals(void); 320 void scheme_init_true_false(void); 321 void scheme_init_symbol_table(void); 322 void scheme_init_symbol_type(Scheme_Startup_Env *env); 323 void scheme_init_type(); 324 void scheme_init_custodian_extractors(); 325 void scheme_init_bignum(); 326 void scheme_init_compenv(); 327 void scheme_init_letrec_check(); 328 void scheme_init_optimize(); 329 void scheme_init_resolve(); 330 void scheme_init_sfs(); 331 void scheme_init_validate(); 332 void scheme_init_port_wait(); 333 void scheme_init_logger_wait(); 334 void scheme_init_struct_wait(); 335 void scheme_init_list(Scheme_Startup_Env *env); 336 void scheme_init_unsafe_list(Scheme_Startup_Env *env); 337 void scheme_init_unsafe_hash(Scheme_Startup_Env *env); 338 void scheme_init_hash_tree(void); 339 void scheme_init_stx(Scheme_Startup_Env *env); 340 void scheme_init_module(Scheme_Startup_Env *env); 341 void scheme_init_module_path_table(void); 342 void scheme_init_port(Scheme_Startup_Env *env); 343 void scheme_init_port_fun(Scheme_Startup_Env *env); 344 void scheme_init_network(Scheme_Startup_Env *env); 345 void scheme_init_file(Scheme_Startup_Env *env); 346 void scheme_init_proc(Scheme_Startup_Env *env); 347 void scheme_init_vector(Scheme_Startup_Env *env); 348 void scheme_init_unsafe_vector(Scheme_Startup_Env *env); 349 void scheme_init_string(Scheme_Startup_Env *env); 350 void scheme_init_number(Scheme_Startup_Env *env); 351 void scheme_init_flfxnum_number(Scheme_Startup_Env *env); 352 void scheme_init_extfl_number(Scheme_Startup_Env *env); 353 void scheme_init_unsafe_number(Scheme_Startup_Env *env); 354 void scheme_init_extfl_unsafe_number(Scheme_Startup_Env *env); 355 void scheme_init_numarith(Scheme_Startup_Env *env); 356 void scheme_init_flfxnum_numarith(Scheme_Startup_Env *env); 357 void scheme_init_extfl_numarith(Scheme_Startup_Env *env); 358 void scheme_init_unsafe_numarith(Scheme_Startup_Env *env); 359 void scheme_init_extfl_unsafe_numarith(Scheme_Startup_Env *env); 360 void scheme_init_numcomp(Scheme_Startup_Env *env); 361 void scheme_init_flfxnum_numcomp(Scheme_Startup_Env *env); 362 void scheme_init_extfl_numcomp(Scheme_Startup_Env *env); 363 void scheme_init_unsafe_numcomp(Scheme_Startup_Env *env); 364 void scheme_init_extfl_unsafe_numcomp(Scheme_Startup_Env *env); 365 void scheme_init_numstr(Scheme_Startup_Env *env); 366 void scheme_init_extfl_numstr(Scheme_Startup_Env *env); 367 void scheme_init_eval(Scheme_Startup_Env *env); 368 void scheme_init_promise(Scheme_Startup_Env *env); 369 void scheme_init_struct(Scheme_Startup_Env *env); 370 void scheme_init_reduced_proc_struct(Scheme_Startup_Env *env); 371 void scheme_init_fun(Scheme_Startup_Env *env); 372 void scheme_init_unsafe_fun(Scheme_Startup_Env *env); 373 void scheme_init_compile(Scheme_Startup_Env *env); 374 void scheme_init_symbol(Scheme_Startup_Env *env); 375 void scheme_init_char_constants(void); 376 void scheme_init_char(Scheme_Startup_Env *env); 377 void scheme_init_unsafe_char(Scheme_Startup_Env *env); 378 void scheme_init_bool(Scheme_Startup_Env *env); 379 void scheme_init_syntax(Scheme_Startup_Env *env); 380 void scheme_init_marshal(Scheme_Startup_Env *env); 381 void scheme_init_error(Scheme_Startup_Env *env); 382 void scheme_init_unsafe_error(Scheme_Startup_Env *env); 383 void scheme_init_exn(Scheme_Startup_Env *env); 384 void scheme_init_debug(Scheme_Startup_Env *env); 385 void scheme_init_thread(Scheme_Startup_Env *env); 386 void scheme_init_unsafe_port(Scheme_Startup_Env *env); 387 void scheme_init_unsafe_thread(Scheme_Startup_Env *env); 388 void scheme_init_read(Scheme_Startup_Env *env); 389 void scheme_init_print(Scheme_Startup_Env *env); 390 #ifndef NO_SCHEME_THREADS 391 void scheme_init_sema(Scheme_Startup_Env *env); 392 #endif 393 void scheme_init_dynamic_extension(Scheme_Startup_Env *env); 394 #ifndef NO_REGEXP_UTILS 395 extern void scheme_regexp_initialize(Scheme_Startup_Env *env); 396 #endif 397 void scheme_init_paramz(Scheme_Startup_Env *env); 398 void scheme_init_parameterization(); 399 void scheme_init_getenv(void); 400 void scheme_init_inspector(void); 401 void scheme_init_compenv_symbol(void); 402 void scheme_init_param_symbol(void); 403 void scheme_init_longdouble_fixup(void); 404 405 #ifndef DONT_USE_FOREIGN 406 void scheme_init_foreign_globals(); 407 #endif 408 void scheme_init_foreign(Scheme_Startup_Env *env); 409 void scheme_init_place(Scheme_Startup_Env *env); 410 void scheme_init_place_per_place(); 411 void scheme_init_places_once(); 412 void scheme_init_futures(Scheme_Startup_Env *env); 413 void scheme_init_futures_once(); 414 void scheme_init_futures_per_place(); 415 void scheme_end_futures_per_place(); 416 void scheme_init_linklet(Scheme_Startup_Env *env); 417 void scheme_init_unsafe_linklet(Scheme_Startup_Env *env); 418 419 void scheme_init_print_buffers_places(void); 420 void scheme_init_string_places(void); 421 void scheme_init_thread_places(void); 422 void scheme_init_linklet_places(void); 423 void scheme_init_eval_places(void); 424 void scheme_init_compile_places(void); 425 void scheme_init_compenv_places(void); 426 void scheme_init_port_places(void); 427 void scheme_init_regexp_places(void); 428 void scheme_init_stx_places(int initial_main_os_thread); 429 void scheme_init_fun_places(void); 430 void scheme_init_sema_places(void); 431 void scheme_init_gmp_places(void); 432 void scheme_init_variable_references_constants(void); 433 void scheme_init_logger(void); 434 void scheme_init_logging_once(void); 435 void scheme_init_file_places(void); 436 void scheme_init_foreign_places(void); 437 void scheme_init_place_local_symbol_table(void); 438 439 Scheme_Logger *scheme_get_main_logger(void); 440 Scheme_Logger *scheme_get_gc_logger(void); 441 Scheme_Logger *scheme_get_future_logger(void); 442 Scheme_Logger *scheme_get_place_logger(void); 443 void scheme_init_logger_config(void); 444 445 void scheme_register_network_evts(); 446 447 void scheme_free_dynamic_extensions(void); 448 void scheme_free_all_code(void); 449 void scheme_clear_locale_cache(void); 450 451 XFORM_NONGCING int scheme_is_multithreaded(int now); 452 453 Scheme_Object *scheme_closure_marshal_name(Scheme_Object *name); 454 void scheme_write_lambda(Scheme_Object *obj, 455 Scheme_Object **_name, 456 Scheme_Object **_ds, 457 Scheme_Object **_closure_map, 458 Scheme_Object **_tl_map); 459 Scheme_Object *scheme_read_lambda(int flags, int closure_size, int num_params, int max_let_depth, 460 Scheme_Object *name, 461 Scheme_Object *ds, 462 Scheme_Object *closure_map, 463 Scheme_Object *tl_map); 464 Scheme_Object *scheme_write_linklet(Scheme_Object *obj); 465 Scheme_Object *scheme_read_linklet(Scheme_Object *obj, int unsafe_ok); 466 467 extern Scheme_Equal_Proc *scheme_type_equals; 468 extern Scheme_Primary_Hash_Proc *scheme_type_hash1s; 469 extern Scheme_Secondary_Hash_Proc *scheme_type_hash2s; 470 471 void scheme_init_port_config(void); 472 void scheme_init_port_fun_config(void); 473 void scheme_init_resolver_config(void); 474 Scheme_Config *scheme_init_error_escape_proc(Scheme_Config *c); 475 void scheme_init_error_config(void); 476 void scheme_init_exn_config(void); 477 #ifdef WINDOWS_PROCESSES 478 void scheme_init_thread_memory(void); 479 #endif 480 void scheme_init_module_resolver(void); 481 482 void scheme_finish_kernel(Scheme_Startup_Env *env); 483 484 void scheme_init_syntax_bindings(void); 485 486 Scheme_Object *scheme_make_initial_inspectors(void); 487 Scheme_Object *scheme_get_current_inspector(void); 488 XFORM_NONGCING Scheme_Object *scheme_get_initial_inspector(void); 489 490 Scheme_Object *scheme_get_local_inspector(); 491 492 extern int scheme_builtin_ref_counter; 493 494 Scheme_Object **scheme_make_builtin_references_table(int *_unsafe_start); 495 Scheme_Object *scheme_make_local(Scheme_Type type, int pos, int flags); 496 497 Scheme_Object *scheme_position_to_builtin(int l); 498 499 typedef struct Scheme_Instance Scheme_Instance; 500 typedef struct Scheme_Linklet Scheme_Linklet; 501 502 void scheme_init_startup(void); /* across places */ 503 void scheme_init_startup_instance(Scheme_Instance *i); 504 505 void *scheme_get_os_thread_like(); 506 void scheme_init_os_thread_like(void *); 507 void scheme_done_os_thread(); 508 int scheme_is_place_main_os_thread(); 509 510 Scheme_Object *scheme_get_startup_export(const char *s); 511 512 extern int scheme_init_load_on_demand; 513 514 extern int scheme_keep_builtin_context; 515 516 /*========================================================================*/ 517 /* constants */ 518 /*========================================================================*/ 519 520 extern Scheme_Object *scheme_symbol_p_proc; 521 extern Scheme_Object *scheme_keyword_p_proc; 522 extern Scheme_Object *scheme_char_p_proc; 523 extern Scheme_Object *scheme_interned_char_p_proc; 524 extern Scheme_Object *scheme_fixnum_p_proc; 525 extern Scheme_Object *scheme_flonum_p_proc; 526 extern Scheme_Object *scheme_extflonum_p_proc; 527 extern Scheme_Object *scheme_real_p_proc; 528 extern Scheme_Object *scheme_number_p_proc; 529 extern Scheme_Object *scheme_apply_proc; 530 extern Scheme_Object *scheme_values_proc; 531 extern Scheme_Object *scheme_procedure_p_proc; 532 extern Scheme_Object *scheme_procedure_arity_includes_proc; 533 extern Scheme_Object *scheme_procedure_specialize_proc; 534 extern Scheme_Object *scheme_void_proc; 535 extern Scheme_Object *scheme_void_p_proc; 536 extern Scheme_Object *scheme_syntax_p_proc; 537 extern Scheme_Object *scheme_check_not_undefined_proc; 538 extern Scheme_Object *scheme_check_assign_not_undefined_proc; 539 extern Scheme_Object *scheme_null_p_proc; 540 extern Scheme_Object *scheme_pair_p_proc; 541 extern Scheme_Object *scheme_mpair_p_proc; 542 extern Scheme_Object *scheme_unsafe_cons_list_proc; 543 extern Scheme_Object *scheme_unsafe_car_proc; 544 extern Scheme_Object *scheme_unsafe_cdr_proc; 545 extern Scheme_Object *scheme_unsafe_mcar_proc; 546 extern Scheme_Object *scheme_unsafe_mcdr_proc; 547 extern Scheme_Object *scheme_unsafe_unbox_proc; 548 extern Scheme_Object *scheme_unsafe_unbox_star_proc; 549 extern Scheme_Object *scheme_unsafe_set_box_star_proc; 550 extern Scheme_Object *scheme_car_proc; 551 extern Scheme_Object *scheme_cdr_proc; 552 extern Scheme_Object *scheme_cons_proc; 553 extern Scheme_Object *scheme_mcons_proc; 554 extern Scheme_Object *scheme_list_p_proc; 555 extern Scheme_Object *scheme_list_proc; 556 extern Scheme_Object *scheme_list_star_proc; 557 extern Scheme_Object *scheme_list_pair_p_proc; 558 extern Scheme_Object *scheme_append_proc; 559 extern Scheme_Object *scheme_vector_proc; 560 extern Scheme_Object *scheme_vector_p_proc; 561 extern Scheme_Object *scheme_vector_length_proc; 562 extern Scheme_Object *scheme_vector_star_length_proc; 563 extern Scheme_Object *scheme_make_vector_proc; 564 extern Scheme_Object *scheme_vector_immutable_proc; 565 extern Scheme_Object *scheme_vector_ref_proc; 566 extern Scheme_Object *scheme_vector_star_ref_proc; 567 extern Scheme_Object *scheme_unsafe_vector_star_ref_proc; 568 extern Scheme_Object *scheme_unsafe_vector_star_set_proc; 569 extern Scheme_Object *scheme_vector_set_proc; 570 extern Scheme_Object *scheme_vector_star_set_proc; 571 extern Scheme_Object *scheme_vector_cas_proc; 572 extern Scheme_Object *scheme_list_to_vector_proc; 573 extern Scheme_Object *scheme_unsafe_vector_length_proc; 574 extern Scheme_Object *scheme_unsafe_vector_star_length_proc; 575 extern Scheme_Object *scheme_unsafe_struct_ref_proc; 576 extern Scheme_Object *scheme_unsafe_struct_star_ref_proc; 577 extern Scheme_Object *scheme_unsafe_struct_set_proc; 578 extern Scheme_Object *scheme_unsafe_struct_star_set_proc; 579 extern Scheme_Object *scheme_hash_proc; 580 extern Scheme_Object *scheme_hasheq_proc; 581 extern Scheme_Object *scheme_hasheqv_proc; 582 extern Scheme_Object *scheme_hash_ref_proc; 583 extern Scheme_Object *scheme_box_p_proc; 584 extern Scheme_Object *scheme_box_proc; 585 extern Scheme_Object *scheme_box_immutable_proc; 586 extern Scheme_Object *scheme_call_with_values_proc; 587 extern Scheme_Object *scheme_call_with_immed_mark_proc; 588 extern Scheme_Object *scheme_make_struct_type_proc; 589 extern Scheme_Object *scheme_make_struct_field_accessor_proc; 590 extern Scheme_Object *scheme_make_struct_field_mutator_proc; 591 extern Scheme_Object *scheme_make_struct_type_property_proc; 592 extern Scheme_Object *scheme_struct_to_vector_proc; 593 extern Scheme_Object *scheme_struct_type_p_proc; 594 extern Scheme_Object *scheme_current_inspector_proc; 595 extern Scheme_Object *scheme_make_inspector_proc; 596 extern Scheme_Object *scheme_varref_const_p_proc; 597 extern Scheme_Object *scheme_varref_unsafe_p_proc; 598 extern Scheme_Object *scheme_unsafe_fxnot_proc; 599 extern Scheme_Object *scheme_unsafe_fxand_proc; 600 extern Scheme_Object *scheme_unsafe_fxior_proc; 601 extern Scheme_Object *scheme_unsafe_fxxor_proc; 602 extern Scheme_Object *scheme_unsafe_fxrshift_proc; 603 extern Scheme_Object *scheme_unsafe_fx_to_fl_proc; 604 extern Scheme_Object *scheme_unsafe_pure_proc; 605 606 extern Scheme_Object *scheme_string_p_proc; 607 extern Scheme_Object *scheme_unsafe_string_length_proc; 608 extern Scheme_Object *scheme_unsafe_string_set_proc; 609 extern Scheme_Object *scheme_unsafe_string_ref_proc; 610 extern Scheme_Object *scheme_byte_string_p_proc; 611 extern Scheme_Object *scheme_unsafe_byte_string_length_proc; 612 extern Scheme_Object *scheme_unsafe_bytes_ref_proc; 613 extern Scheme_Object *scheme_unsafe_bytes_set_proc; 614 615 extern Scheme_Object *scheme_unsafe_real_add1_proc; 616 extern Scheme_Object *scheme_unsafe_real_sub1_proc; 617 extern Scheme_Object *scheme_unsafe_real_abs_proc; 618 extern Scheme_Object *scheme_unsafe_real_plus_proc; 619 extern Scheme_Object *scheme_unsafe_real_minus_proc; 620 extern Scheme_Object *scheme_unsafe_real_times_proc; 621 extern Scheme_Object *scheme_unsafe_real_divide_proc; 622 extern Scheme_Object *scheme_unsafe_real_modulo_proc; 623 extern Scheme_Object *scheme_unsafe_real_quotient_proc; 624 extern Scheme_Object *scheme_unsafe_real_remainder_proc; 625 626 extern Scheme_Object *scheme_unsafe_real_eq_proc; 627 extern Scheme_Object *scheme_unsafe_real_lt_proc; 628 extern Scheme_Object *scheme_unsafe_real_gt_proc; 629 extern Scheme_Object *scheme_unsafe_real_lt_eq_proc; 630 extern Scheme_Object *scheme_unsafe_real_gt_eq_proc; 631 extern Scheme_Object *scheme_unsafe_real_min_proc; 632 extern Scheme_Object *scheme_unsafe_real_max_proc; 633 634 extern Scheme_Object *scheme_unsafe_fx_eq_proc; 635 extern Scheme_Object *scheme_unsafe_fx_lt_proc; 636 extern Scheme_Object *scheme_unsafe_fx_gt_proc; 637 extern Scheme_Object *scheme_unsafe_fx_lt_eq_proc; 638 extern Scheme_Object *scheme_unsafe_fx_gt_eq_proc; 639 extern Scheme_Object *scheme_unsafe_fx_min_proc; 640 extern Scheme_Object *scheme_unsafe_fx_max_proc; 641 extern Scheme_Object *scheme_unsafe_fx_plus_proc; 642 extern Scheme_Object *scheme_unsafe_fx_minus_proc; 643 extern Scheme_Object *scheme_unsafe_fx_times_proc; 644 645 extern Scheme_Object *scheme_unsafe_char_eq_proc; 646 extern Scheme_Object *scheme_unsafe_char_lt_proc; 647 extern Scheme_Object *scheme_unsafe_char_gt_proc; 648 extern Scheme_Object *scheme_unsafe_char_lt_eq_proc; 649 extern Scheme_Object *scheme_unsafe_char_gt_eq_proc; 650 extern Scheme_Object *scheme_unsafe_char_to_integer_proc; 651 652 extern Scheme_Object *scheme_not_proc; 653 extern Scheme_Object *scheme_true_object_p_proc; 654 extern Scheme_Object *scheme_boolean_p_proc; 655 extern Scheme_Object *scheme_eq_proc; 656 extern Scheme_Object *scheme_eqv_proc; 657 extern Scheme_Object *scheme_equal_proc; 658 659 extern Scheme_Object *scheme_def_exit_proc; 660 extern Scheme_Object *scheme_system_type_proc; 661 662 extern Scheme_Object *scheme_unsafe_poller_proc; 663 664 extern Scheme_Object *scheme_unsafe_poller_proc; 665 666 THREAD_LOCAL_DECL(extern Scheme_Object *scheme_orig_stdout_port); 667 THREAD_LOCAL_DECL(extern Scheme_Object *scheme_orig_stdin_port); 668 THREAD_LOCAL_DECL(extern Scheme_Object *scheme_orig_stderr_port); 669 670 extern Scheme_Object *scheme_arity_at_least, *scheme_make_arity_at_least; 671 672 extern Scheme_Object *scheme_write_proc, *scheme_display_proc, *scheme_print_proc; 673 674 extern Scheme_Object *scheme_raise_arity_error_proc; 675 676 extern Scheme_Object *scheme_date; 677 678 extern Scheme_Object *scheme_recur_symbol, *scheme_display_symbol, *scheme_write_special_symbol; 679 680 extern Scheme_Object *scheme_none_symbol, *scheme_line_symbol, *scheme_block_symbol; 681 682 extern Scheme_Object *scheme_paren_shape_symbol; 683 extern Scheme_Object *scheme_paren_shape_preserve_square; 684 extern Scheme_Object *scheme_paren_shape_preserve_curly; 685 extern Scheme_Hash_Tree *scheme_source_stx_props; 686 687 extern Scheme_Object *scheme_stack_dump_key; 688 689 extern Scheme_Object *scheme_root_prompt_tag; 690 extern Scheme_Object *scheme_default_prompt_tag; 691 692 THREAD_LOCAL_DECL(extern Scheme_Object *scheme_system_idle_channel); 693 694 extern Scheme_Object *scheme_input_port_property, *scheme_output_port_property; 695 extern Scheme_Object *scheme_cpointer_property; 696 697 extern Scheme_Object *scheme_equal_property; 698 extern Scheme_Object *scheme_object_name_property; 699 extern Scheme_Object *scheme_impersonator_of_property; 700 701 extern Scheme_Object *scheme_app_mark_impersonator_property; 702 703 extern Scheme_Object *scheme_no_arity_property; 704 705 extern Scheme_Object *scheme_authentic_property; 706 extern Scheme_Object *scheme_sealed_property; 707 708 extern Scheme_Object *scheme_chaperone_undefined_property; 709 710 extern Scheme_Object *scheme_reduced_procedure_struct; 711 712 /* recycle some constants that can't appear in code: */ 713 #define scheme_constant_key scheme_stack_dump_key 714 #define scheme_fixed_key scheme_default_prompt_tag 715 716 extern Scheme_Object *scheme_double_ctype; 717 extern Scheme_Object *scheme_float_ctype; 718 extern Scheme_Object *scheme_pointer_ctype; 719 extern Scheme_Object *scheme_int8_ctype; 720 extern Scheme_Object *scheme_uint8_ctype; 721 extern Scheme_Object *scheme_int16_ctype; 722 extern Scheme_Object *scheme_uint16_ctype; 723 extern Scheme_Object *scheme_int32_ctype; 724 extern Scheme_Object *scheme_uint32_ctype; 725 extern Scheme_Object *scheme_int64_ctype; 726 extern Scheme_Object *scheme_uint64_ctype; 727 728 /*========================================================================*/ 729 /* thread state and maintenance */ 730 /*========================================================================*/ 731 732 #define RUNSTACK_IS_GLOBAL 733 734 #ifdef RUNSTACK_IS_GLOBAL 735 THREAD_LOCAL_DECL(extern Scheme_Object **scheme_current_runstack); 736 THREAD_LOCAL_DECL(extern Scheme_Object **scheme_current_runstack_start); 737 THREAD_LOCAL_DECL(extern MZ_MARK_STACK_TYPE scheme_current_cont_mark_stack); 738 THREAD_LOCAL_DECL(extern MZ_MARK_POS_TYPE scheme_current_cont_mark_pos); 739 # define MZ_RUNSTACK scheme_current_runstack 740 # define MZ_RUNSTACK_START scheme_current_runstack_start 741 # define MZ_CONT_MARK_STACK scheme_current_cont_mark_stack 742 # define MZ_CONT_MARK_POS scheme_current_cont_mark_pos 743 #else 744 # define MZ_RUNSTACK (scheme_current_thread->runstack) 745 # define MZ_RUNSTACK_START (scheme_current_thread->runstack_start) 746 # define MZ_CONT_MARK_STACK (scheme_current_thread->cont_mark_stack) 747 # define MZ_CONT_MARK_POS (scheme_current_thread->cont_mark_pos) 748 #endif 749 750 #ifdef MZ_PRECISE_GC 751 # define RUNSTACK_HEADER_FIELDS 5 752 #endif 753 754 THREAD_LOCAL_DECL(extern volatile int scheme_fuel_counter); 755 756 THREAD_LOCAL_DECL(extern Scheme_Thread *scheme_main_thread); 757 758 #if defined(MZ_USE_PLACES) || defined(MZ_USE_FUTURES) || defined(USE_PTHREAD_THREAD_TIMER) || defined(WINDOWS_FILE_HANDLES) 759 # define MZ_USE_MZRT 760 #endif 761 762 #ifdef MZ_USE_MZRT 763 # include "mzrt.h" 764 #endif 765 766 #ifdef MZ_USE_PLACES 767 extern mz_proc_thread *scheme_master_proc_thread; 768 THREAD_LOCAL_DECL(extern mz_proc_thread *proc_thread_self); 769 #endif 770 771 THREAD_LOCAL_DECL(extern int scheme_no_stack_overflow); 772 773 typedef struct Scheme_Thread_Set { 774 Scheme_Object so; 775 struct Scheme_Thread_Set *parent; 776 Scheme_Object *first; 777 Scheme_Object *next; 778 Scheme_Object *prev; 779 Scheme_Object *search_start; 780 Scheme_Object *current; 781 } Scheme_Thread_Set; 782 783 THREAD_LOCAL_DECL(extern Scheme_Thread_Set *scheme_thread_set_top); 784 785 #define SCHEME_TAIL_COPY_THRESHOLD 5 786 787 /* Flags for Scheme_Thread's `running' field: */ 788 #define MZTHREAD_RUNNING 0x1 789 #define MZTHREAD_SUSPENDED 0x2 790 #define MZTHREAD_KILLED 0x4 791 #define MZTHREAD_NEED_KILL_CLEANUP 0x8 792 #define MZTHREAD_USER_SUSPENDED 0x10 793 #define MZTHREAD_NEED_SUSPEND_CLEANUP 0x20 794 #define MZTHREAD_STILL_RUNNING(running) ((running) && !((running) & MZTHREAD_KILLED)) 795 796 #ifdef WINDOWS_PROCESSES 797 MZ_EXTERN struct Scheme_Thread_Memory *scheme_remember_thread(void *, int); 798 void scheme_remember_subthread(struct Scheme_Thread_Memory *, void *); 799 MZ_EXTERN void scheme_forget_thread(struct Scheme_Thread_Memory *); 800 void scheme_forget_subthread(struct Scheme_Thread_Memory *); 801 void scheme_suspend_remembered_threads(void); 802 void scheme_resume_remembered_threads(void); 803 #endif 804 805 void scheme_thread_start_child(Scheme_Thread *child, Scheme_Object *child_thunk); 806 void scheme_do_thread_start_child(Scheme_Thread *child, Scheme_Object *child_thunk); 807 808 int scheme_wait_until_suspend_ok(void); 809 810 #ifdef MZ_USE_MZRT 811 extern void scheme_check_foreign_work(void); 812 #endif 813 814 #ifndef DONT_USE_FOREIGN 815 XFORM_NONGCING extern void *scheme_extract_pointer(Scheme_Object *v); 816 #endif 817 818 Scheme_Object *scheme_foreign_ptr_ref(int argc, Scheme_Object **argv); 819 void scheme_foreign_ptr_set(int argc, Scheme_Object **argv); 820 821 Scheme_Object *scheme_cpointer_tag(Scheme_Object *ptr); 822 void scheme_set_cpointer_tag(Scheme_Object *ptr, Scheme_Object *val); 823 824 void scheme_kickoff_green_thread_time_slice_timer(intptr_t usec); 825 826 void scheme_prepare_this_thread_for_GC(Scheme_Thread *t); 827 828 Scheme_Object **scheme_alloc_runstack(intptr_t len); 829 void scheme_set_runstack_limits(Scheme_Object **rs, intptr_t len, intptr_t start, intptr_t end); 830 void scheme_check_runstack_edge(Scheme_Object **rs); 831 832 void scheme_alloc_list_stack(Scheme_Thread *p); 833 void scheme_clean_list_stack(Scheme_Thread *p); 834 835 Scheme_Object *scheme_get_thread_dead(Scheme_Thread *p); 836 Scheme_Object *scheme_get_thread_suspend(Scheme_Thread *p); 837 Scheme_Object *scheme_get_thread_sync(Scheme_Thread *p); 838 void scheme_clear_thread_sync(Scheme_Thread *p); 839 840 void scheme_zero_unneeded_rands(Scheme_Thread *p); 841 842 void scheme_realloc_tail_buffer(Scheme_Thread *p); 843 844 int scheme_can_break(Scheme_Thread *p); 845 void scheme_thread_wait(Scheme_Object *thread); 846 847 # define DO_CHECK_FOR_BREAK(p, e) \ 848 if (DECREMENT_FUEL(scheme_fuel_counter, 1) <= 0) { \ 849 e scheme_thread_block(0); \ 850 (p)->ran_some = 1; \ 851 } 852 853 THREAD_LOCAL_DECL(extern int scheme_overflow_count); 854 855 #define MZTHREADELEM(p, x) scheme_ ## x 856 857 struct Scheme_Custodian { 858 Scheme_Object so; 859 char shut_down, has_limit, recorded; 860 int count, alloc, elems; 861 Scheme_Object ***boxes; 862 Scheme_Custodian_Reference **mrefs; 863 Scheme_Close_Custodian_Client **closers; 864 void **data; 865 void ***data_ptr; /* points to `data`, registered as finalizer data for strong retention */ 866 Scheme_Object *post_callbacks; /* additional callbacks run after all others */ 867 868 /* weak indirections: */ 869 Scheme_Custodian_Reference *parent; 870 Scheme_Custodian_Reference *sibling; 871 Scheme_Custodian_Reference *children; 872 873 Scheme_Custodian_Reference *global_next; 874 Scheme_Custodian_Reference *global_prev; 875 876 #ifdef MZ_PRECISE_GC 877 int gc_owner_set; 878 Scheme_Object *cust_boxes; 879 int num_cust_boxes, checked_cust_boxes; 880 int really_doing_accounting; 881 #endif 882 }; 883 884 typedef struct Scheme_Custodian_Box { 885 Scheme_Object so; 886 Scheme_Custodian *cust; 887 Scheme_Object *v; 888 } Scheme_Custodian_Box; 889 890 Scheme_Thread *scheme_do_close_managed(Scheme_Custodian *m, Scheme_Exit_Closer_Func f); 891 Scheme_Custodian *scheme_get_current_custodian(void); 892 void scheme_run_atexit_closers_on_all(Scheme_Exit_Closer_Func alt); 893 void scheme_run_atexit_closers(Scheme_Object *o, Scheme_Close_Custodian_Client *f, void *data); 894 895 typedef struct Scheme_Security_Guard { 896 Scheme_Object so; 897 struct Scheme_Security_Guard *parent; 898 Scheme_Object *file_proc; /* who-symbol path mode-symbol -> void */ 899 Scheme_Object *network_proc; /* who-symbol host-string-or-'listen port-k -> void */ 900 Scheme_Object *link_proc; /* who-symbol path path -> void */ 901 } Scheme_Security_Guard; 902 903 /* Always allocated on the stack: */ 904 typedef struct { 905 Scheme_Thread *false_positive_ok; /* non-zero => return 1 to swap in thread rather than running Racket code */ 906 int potentially_false_positive; /* => returning 1 to swap thread in, but truth may be 0 */ 907 Scheme_Object *current_syncing; 908 double sleep_end; 909 int w_i; 910 char spin, is_poll, no_redirect; 911 Scheme_Object *replace_chain; /* turns non-tail replace_evt recursion into a loop */ 912 } Scheme_Schedule_Info; 913 914 typedef Scheme_Object *(*Scheme_Accept_Sync)(Scheme_Object *wrap); 915 916 void scheme_set_sync_target(Scheme_Schedule_Info *sinfo, Scheme_Object *target, 917 Scheme_Object *wrap, Scheme_Object *nack, 918 int repost, int retry, Scheme_Accept_Sync accept); 919 struct Syncing; 920 void scheme_accept_sync(struct Syncing *syncing, int i); 921 922 struct Syncing *scheme_make_syncing(int argc, Scheme_Object **argv); 923 int scheme_syncing_ready(struct Syncing *s, Scheme_Schedule_Info *sinfo, int can_suspend); 924 void scheme_syncing_needs_wakeup(struct Syncing *s, void *fds); 925 void scheme_escape_during_sync(struct Syncing *syncing); 926 Scheme_Object *scheme_syncing_result(struct Syncing *syncing, int tailok); 927 928 struct Syncing *scheme_replace_evt_get(Scheme_Object *active_replace); 929 struct Syncing *scheme_replace_evt_nack(Scheme_Object *active_replace); 930 struct Syncing *scheme_replace_evt_needs_wakeup(Scheme_Object *o); 931 932 typedef int (*Scheme_Ready_Fun_FPC)(Scheme_Object *o, Scheme_Schedule_Info *sinfo); 933 typedef int (*Scheme_Out_Ready_Fun_FPC)(Scheme_Output_Port *port, Scheme_Schedule_Info *sinfo); 934 typedef int (*Scheme_In_Ready_Fun_FPC)(Scheme_Input_Port *port, Scheme_Schedule_Info *sinfo); 935 936 void scheme_check_break_now(void); 937 938 THREAD_LOCAL_DECL(extern int scheme_main_was_once_suspended); 939 940 /* A "flattened" config. Maps parameters to thread cells. */ 941 typedef struct { 942 MZTAG_IF_REQUIRED 943 Scheme_Bucket_Table *extensions; 944 Scheme_Object *prims[mzFLEX_ARRAY_DECL]; 945 } Scheme_Parameterization; 946 947 struct Scheme_Config { 948 Scheme_Object so; 949 Scheme_Hash_Tree *ht; 950 Scheme_Parameterization *root; 951 }; 952 953 extern Scheme_Object *scheme_parameterization_key; 954 extern Scheme_Object *scheme_exn_handler_key; 955 extern Scheme_Object *scheme_break_enabled_key; 956 957 Scheme_Object *scheme_extend_parameterization(int argc, Scheme_Object *args[]); 958 XFORM_NONGCING int scheme_is_parameter(Scheme_Object *o); 959 960 extern void scheme_flatten_config(Scheme_Config *c); 961 962 extern Scheme_Object *scheme_apply_thread_thunk(Scheme_Object *rator); 963 964 Scheme_Custodian* scheme_custodian_extract_reference(Scheme_Custodian_Reference *mr); 965 966 /*========================================================================*/ 967 /* hash tables and linklet instances */ 968 /*========================================================================*/ 969 970 /* a primitive constant: */ 971 #define GLOB_IS_CONST 1 972 /* always defined as the same kind of value (e.g., proc with a particular arity): */ 973 #define GLOB_IS_CONSISTENT 2 974 /* whether home_link is strong or weak: */ 975 #define GLOB_STRONG_HOME_LINK 4 976 /* a kernel constant: */ 977 #define GLOB_HAS_REF_ID 16 978 /* can cast to Scheme_Bucket_With_Home: */ 979 #define GLOB_HAS_HOME_PTR 32 980 /* Racket-level constant (cannot be changed further): */ 981 #define GLOB_IS_IMMUTATED 64 982 /* Linked from other (cannot be undefined): */ 983 #define GLOB_IS_LINKED 128 984 985 typedef struct { 986 Scheme_Bucket bucket; 987 short flags, id; 988 } Scheme_Bucket_With_Flags; 989 990 typedef Scheme_Bucket_With_Flags Scheme_Bucket_With_Ref_Id; 991 992 typedef struct { 993 Scheme_Bucket_With_Ref_Id bucket; 994 Scheme_Object *home_link; /* weak to Scheme_Instance *, except when GLOB_STRONG_HOME_LINK */ 995 } Scheme_Bucket_With_Home; 996 997 XFORM_NONGCING Scheme_Instance *scheme_get_bucket_home(Scheme_Bucket *b); 998 void scheme_set_bucket_home(Scheme_Bucket *b, Scheme_Instance *e); 999 Scheme_Object *scheme_get_home_weak_link(Scheme_Instance *e); 1000 1001 Scheme_Object * 1002 scheme_get_primitive_global(Scheme_Object *var, Scheme_Env *env, 1003 int bucket_ok, int can_opt, int signal); 1004 1005 void scheme_add_bucket_to_table(Scheme_Bucket_Table *table, Scheme_Bucket *b); 1006 Scheme_Bucket *scheme_bucket_or_null_from_table(Scheme_Bucket_Table *table, const char *key, int add); 1007 1008 typedef unsigned int hash_tree_bitmap_t; /* must be unsigned int */ 1009 struct Scheme_Hash_Tree { 1010 Scheme_Inclhash_Object iso; /* 0 => keys only; 0x1 => keys and values; 0x3 => keys, values, and codes */ 1011 hash_tree_bitmap_t bitmap; 1012 intptr_t count; 1013 Scheme_Object *els[mzFLEX_ARRAY_DECL]; /* keys, then vals (if any), then codes (if any) */ 1014 }; 1015 1016 #define SCHEME_HASHTR_FLAGS(tr) MZ_OPT_HASH_KEY(&(tr)->iso) 1017 #define SCHEME_HASHTR_KIND(tr) (SCHEME_HASHTR_FLAGS(tr) & 0x3) 1018 1019 #define SCHEME_HASHTR_TYPE(tr) (SAME_TYPE(SCHEME_TYPE(tr), scheme_hash_tree_indirection_type) \ 1020 ? SCHEME_TYPE(((Scheme_Hash_Tree *)tr)->els[0]) \ 1021 : SCHEME_TYPE(tr)) 1022 1023 Scheme_Object *scheme_intern_literal_string(Scheme_Object *str); 1024 Scheme_Object *scheme_intern_literal_number(Scheme_Object *num); 1025 1026 #define SCHEME_BT_KIND_WEAK 1 1027 #define SCHEME_BT_KIND_LATE 2 1028 #define SCHEME_BT_KIND_EPHEMERON 3 1029 1030 /*========================================================================*/ 1031 /* hash functions */ 1032 /*========================================================================*/ 1033 1034 Scheme_Object *scheme_make_immutable_hash(int argc, Scheme_Object *argv[]); 1035 Scheme_Object *scheme_make_immutable_hasheq(int argc, Scheme_Object *argv[]); 1036 Scheme_Object *scheme_make_immutable_hasheqv(int argc, Scheme_Object *argv[]); 1037 Scheme_Object *scheme_hash_eq_p(int argc, Scheme_Object *argv[]); 1038 Scheme_Object *scheme_hash_eqv_p(int argc, Scheme_Object *argv[]); 1039 Scheme_Object *scheme_hash_equal_p(int argc, Scheme_Object *argv[]); 1040 Scheme_Object *scheme_hash_table_put(int argc, Scheme_Object *argv[]); 1041 Scheme_Object *scheme_hash_table_iterate_start(int argc, Scheme_Object *argv[]); 1042 Scheme_Object *scheme_hash_table_iterate_next(int argc, Scheme_Object *argv[]); 1043 Scheme_Object *scheme_hash_table_iterate_value(int argc, Scheme_Object *argv[]); 1044 Scheme_Object *scheme_hash_table_iterate_key(int argc, Scheme_Object *argv[]); 1045 1046 Scheme_Object *scheme_hash_get_key(Scheme_Hash_Table *table, Scheme_Object *key); 1047 Scheme_Object *scheme_hash_get_w_key_wraps(Scheme_Hash_Table *table, Scheme_Object *key, 1048 Scheme_Object *key_wraps, Scheme_Object **_interned_key); 1049 void scheme_hash_set_w_key_wraps(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object *val, 1050 Scheme_Object *key_wraps); 1051 Scheme_Object *scheme_lookup_key_in_table(Scheme_Bucket_Table *table, const char *key); 1052 Scheme_Bucket *scheme_bucket_or_null_from_table_w_key_wraps(Scheme_Bucket_Table *table, 1053 const char *key, int add, 1054 Scheme_Object *key_wraps); 1055 void scheme_add_to_table_w_key_wraps(Scheme_Bucket_Table *table, const char *key, void *val, 1056 int constant, Scheme_Object *key_wraps); 1057 void *scheme_lookup_in_table_w_key_wraps(Scheme_Bucket_Table *table, const char *key, 1058 Scheme_Object *key_wraps, Scheme_Object **_interned_key); 1059 Scheme_Object *scheme_hash_tree_get_key(Scheme_Hash_Tree *tree, Scheme_Object *key); 1060 Scheme_Object *scheme_hash_tree_get_w_key_wraps(Scheme_Hash_Tree *tree, Scheme_Object *key, 1061 Scheme_Object *key_wraps, Scheme_Object **_interned_key); 1062 Scheme_Hash_Tree *scheme_hash_tree_set_w_key_wraps(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val, 1063 Scheme_Object *key_wraps); 1064 1065 Scheme_Object *scheme_unsafe_hash_tree_start(Scheme_Hash_Tree *ht); 1066 XFORM_NONGCING_NONALIASING void scheme_unsafe_hash_tree_subtree(Scheme_Object *obj, Scheme_Object *args, 1067 Scheme_Hash_Tree **_subtree, int *_i); 1068 XFORM_NONGCING Scheme_Object *scheme_unsafe_hash_tree_access(Scheme_Hash_Tree *subtree, int i); 1069 Scheme_Object *scheme_unsafe_hash_tree_next(Scheme_Hash_Tree *ht, Scheme_Object *args); 1070 Scheme_Object *scheme_hash_tree_next_pos(Scheme_Hash_Tree *tree, mzlonglong pos); 1071 int scheme_hash_tree_equal(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2); 1072 int scheme_is_hash_tree_equal(Scheme_Object *o); 1073 int scheme_is_hash_tree_eqv(Scheme_Object *o); 1074 1075 Scheme_Object *scheme_chaperone_hash_key(const char *name, Scheme_Object *table, Scheme_Object *key); 1076 void scheme_chaperone_hash_key_value(const char *name, Scheme_Object *obj, Scheme_Object *k, 1077 Scheme_Object **_chap_key, Scheme_Object **_chap_val, 1078 int ischap); 1079 1080 /*========================================================================*/ 1081 /* structs */ 1082 /*========================================================================*/ 1083 1084 typedef struct Scheme_Inspector { 1085 Scheme_Object so; 1086 int depth; 1087 struct Scheme_Inspector *superior; 1088 } Scheme_Inspector; 1089 1090 typedef struct Scheme_Struct_Property { 1091 Scheme_Object so; 1092 char can_impersonate; /* 1 if impersonatable property, 0 otherwise */ 1093 Scheme_Object *name; /* a symbol */ 1094 Scheme_Object *guard; /* NULL, a procedure, or 'can-impersonate */ 1095 Scheme_Object *supers; /* implied properties: listof (cons <prop> <proc>) */ 1096 } Scheme_Struct_Property; 1097 1098 int scheme_inspector_sees_part(Scheme_Object *s, Scheme_Object *insp, int pos); 1099 int scheme_struct_is_transparent(Scheme_Object *s); 1100 1101 typedef struct Scheme_Struct_Type { 1102 Scheme_Inclhash_Object iso; /* scheme_struct_type_type */ 1103 mzshort num_slots; /* initialized + auto + parent-initialized + parent-auto */ 1104 mzshort num_islots; /* initialized + parent-initialized */ 1105 mzshort name_pos; 1106 int more_flags; /* STRUCT_TYPE_FLAG_AUTHENTIC => chaperones/impersonators disallowed 1107 STRUCT_TYPE_FLAG_SEALED => subtypes disallowed 1108 STRUCT_TYPE_FLAG_NONFAIL_CONSTRUCTOR => constructor never fails 1109 STRUCT_TYPE_FLAG_SYSTEM_OPAQUE => #f for `object-name`, for example */ 1110 1111 Scheme_Object *name; 1112 1113 Scheme_Object *inspector; 1114 Scheme_Object *accessor, *mutator; 1115 Scheme_Object *prefab_key; 1116 1117 Scheme_Object *uninit_val; 1118 1119 Scheme_Object **props; /* normally an array of pair of (property, value) pairs */ 1120 int num_props; /* < 0 => props is really a hash table */ 1121 1122 Scheme_Object *proc_attr; /* int (position) or proc, only for proc_struct */ 1123 char *immutables; /* for immediate slots, only (not parent) */ 1124 1125 Scheme_Object *guard; 1126 1127 #if defined(MZ_GC_BACKTRACE) && defined(MZ_PRECISE_GC) 1128 intptr_t current_instance_count; 1129 intptr_t current_instance_sizes; 1130 intptr_t total_instance_count; 1131 intptr_t total_instance_sizes; 1132 #endif 1133 1134 struct Scheme_Struct_Type *parent_types[mzFLEX_ARRAY_DECL]; 1135 } Scheme_Struct_Type; 1136 1137 #define STRUCT_TYPE_ALL_IMMUTABLE 0x1 1138 #define STRUCT_TYPE_CHECKED_PROC 0x2 1139 1140 /* for `more_flags` field */ 1141 #define STRUCT_TYPE_FLAG_NONFAIL_CONSTRUCTOR 0x1 1142 #define STRUCT_TYPE_FLAG_SYSTEM_OPAQUE 0x2 1143 #define STRUCT_TYPE_FLAG_AUTHENTIC 0x4 1144 #define STRUCT_TYPE_FLAG_SEALED 0x8 1145 1146 typedef struct Scheme_Structure 1147 { 1148 Scheme_Object so; 1149 Scheme_Struct_Type *stype; 1150 Scheme_Object *slots[mzFLEX_ARRAY_DECL]; 1151 } Scheme_Structure; 1152 1153 #define MAX_STRUCT_FIELD_COUNT 32768 1154 #define MAX_STRUCT_FIELD_COUNT_STR "32768" 1155 1156 #ifdef MZ_USE_PLACES 1157 typedef struct Scheme_Serialized_Structure 1158 { 1159 Scheme_Object so; 1160 Scheme_Object *prefab_key; 1161 int num_slots; 1162 Scheme_Object *slots[mzFLEX_ARRAY_DECL]; 1163 } Scheme_Serialized_Structure; 1164 #endif 1165 1166 #define SCHEME_STRUCT_TYPE(o) (((Scheme_Structure *)o)->stype) 1167 1168 #define SCHEME_STRUCT_NUM_SLOTS(o) (SCHEME_STRUCT_TYPE(o)->num_slots) 1169 #define SCHEME_STRUCT_NAME_SYM(o) (SCHEME_STRUCT_TYPE(o)->name) 1170 1171 Scheme_Object **scheme_make_struct_names_from_array(const char *base, 1172 int fcount, 1173 const char **field_names, 1174 int flags, int *count_out); 1175 Scheme_Object *scheme_make_struct_type_from_string(const char *base, 1176 Scheme_Object *parent, 1177 int num_fields, 1178 Scheme_Object *props, 1179 Scheme_Object *guard, 1180 int immutable); 1181 1182 Scheme_Object *scheme_struct_to_vector(Scheme_Object *_s, Scheme_Object *unknown_val, Scheme_Object *insp); 1183 1184 Scheme_Object *scheme_extract_struct_procedure(Scheme_Object *obj, int num_rands, Scheme_Object **rands, int *is_method); 1185 1186 Scheme_Object *scheme_proc_struct_name_source(Scheme_Object *a); 1187 Scheme_Object *scheme_object_name(Scheme_Object *a); 1188 1189 int scheme_is_simple_struct_type(Scheme_Struct_Type *stype); 1190 1191 Scheme_Object *scheme_is_writable_struct(Scheme_Object *s); 1192 Scheme_Object *scheme_print_attribute_ref(Scheme_Object *s); 1193 1194 #define SCHEME_STRUCT_INSPECTOR(obj) (((Scheme_Structure *)obj)->stype->inspector) 1195 1196 extern Scheme_Object *scheme_source_property; 1197 extern Scheme_Object *scheme_module_path_property; 1198 1199 Scheme_Struct_Type *scheme_lookup_prefab_type(Scheme_Object *key, int field_count); 1200 Scheme_Object *scheme_make_blank_prefab_struct_instance(Scheme_Struct_Type *stype); 1201 Scheme_Object *scheme_make_prefab_struct_instance(Scheme_Struct_Type *stype, 1202 Scheme_Object *vec); 1203 Scheme_Object *scheme_clone_prefab_struct_instance(Scheme_Structure *s); 1204 Scheme_Struct_Type *scheme_make_prefab_struct_type_in_master(Scheme_Object *base, 1205 Scheme_Object *parent, 1206 int num_slots, 1207 int num_islots, 1208 Scheme_Object *uninit_val, 1209 char *immutable_pos_list); 1210 Scheme_Struct_Type *scheme_make_prefab_struct_type_raw(Scheme_Object *base, 1211 Scheme_Object *parent, 1212 int num_slots, 1213 int num_islots, 1214 Scheme_Object *uninit_val, 1215 char *immutable_pos_list); 1216 XFORM_NONGCING Scheme_Object *scheme_prefab_struct_key(Scheme_Object *s); 1217 #ifdef MZ_USE_PLACES 1218 Scheme_Object *scheme_make_serialized_struct_instance(Scheme_Object *s, int num_slots); 1219 #endif 1220 1221 Scheme_Object *scheme_struct_getter(int argc, Scheme_Object **args, Scheme_Object *prim); 1222 Scheme_Object *scheme_struct_setter(int argc, Scheme_Object **args, Scheme_Object *prim); 1223 1224 void scheme_force_struct_type_info(Scheme_Struct_Type *stype); 1225 1226 Scheme_Object *scheme_extract_checked_procedure(int argc, Scheme_Object **argv); 1227 1228 Scheme_Object *scheme_rename_struct_proc(Scheme_Object *p, Scheme_Object *sym); 1229 1230 #if defined(MZ_GC_BACKTRACE) && defined(MZ_PRECISE_GC) 1231 Scheme_Object *scheme_add_builtin_struct_types(Scheme_Object *accum); 1232 #endif 1233 1234 typedef struct Scheme_Chaperone { 1235 Scheme_Inclhash_Object iso; /* 0x1 => impersonator, rather than a checking chaperone */ 1236 Scheme_Object *val; /* root object */ 1237 Scheme_Object *prev; /* immediately chaperoned object */ 1238 Scheme_Object *props; /* NULL, a vector, or a hash tree */ 1239 Scheme_Object *redirects; /* specific to the type of chaperone and root object */ 1240 } Scheme_Chaperone; 1241 1242 #define SCHEME_CHAPERONE_FLAGS(c) MZ_OPT_HASH_KEY(&(c)->iso) 1243 #define SCHEME_CHAPERONE_IS_IMPERSONATOR 0x1 1244 #define SCHEME_PROC_CHAPERONE_CALL_DIRECT 0x2 1245 /* 1246 We use the same bit to indicate either chaperone-vector* as well as 1247 procedure chaperones which do not call interposition procedures. 1248 This is ok because no value is simultaneously a vector and a procedure, 1249 so we can safely reuse the bit. 1250 */ 1251 #define SCHEME_VEC_CHAPERONE_STAR 0x2 1252 1253 #define SCHEME_CHAPERONE_VAL(obj) (((Scheme_Chaperone *)obj)->val) 1254 1255 #define SCHEME_P_CHAPERONEP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_proc_chaperone_type)) 1256 #define SCHEME_NP_CHAPERONEP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_chaperone_type)) 1257 1258 /* Does the shape of the redirects field match the pattern for particular chaperone types */ 1259 #define SCHEME_REDIRECTS_PROCEDUREP(red) (SCHEME_VECTORP(red) \ 1260 && (SCHEME_VEC_SIZE(red) & 1)) 1261 #define SCHEME_REDIRECTS_STRUCTP(red) (SCHEME_VECTORP(red) \ 1262 && SCHEME_VEC_SIZE(red) \ 1263 && !(SCHEME_VEC_SIZE(red) & 1)) 1264 #define SCHEME_REDIRECTS_PROP_ONLY_VECTORP(red) (SCHEME_VECTORP(red) \ 1265 && !(SCHEME_VEC_SIZE(red))) 1266 1267 #define SCHEME_CHAPERONE_VECTORP(obj) (SCHEME_VECTORP(obj) \ 1268 || (SCHEME_NP_CHAPERONEP(obj) && SCHEME_VECTORP(SCHEME_CHAPERONE_VAL(obj)))) 1269 #define SCHEME_CHAPERONE_BOXP(obj) (SCHEME_BOXP(obj) \ 1270 || (SCHEME_NP_CHAPERONEP(obj) && SCHEME_BOXP(SCHEME_CHAPERONE_VAL(obj)))) 1271 #define SCHEME_CHAPERONE_STRUCTP(obj) (SCHEME_STRUCTP(obj) \ 1272 || (SCHEME_CHAPERONEP(obj) && SCHEME_STRUCTP(SCHEME_CHAPERONE_VAL(obj)))) 1273 #define SCHEME_CHAPERONE_PROC_STRUCTP(obj) (SCHEME_PROC_STRUCTP(obj) \ 1274 || (SCHEME_P_CHAPERONEP(obj) && SCHEME_PROC_STRUCTP(SCHEME_CHAPERONE_VAL(obj)))) 1275 #define SCHEME_CHAPERONE_STRUCT_TYPEP(obj) (SCHEME_STRUCT_TYPEP(obj) \ 1276 || (SCHEME_NP_CHAPERONEP(obj) && SCHEME_STRUCT_TYPEP(SCHEME_CHAPERONE_VAL(obj)))) 1277 #define SCHEME_CHAPERONE_HASHTP(obj) (SCHEME_HASHTP(obj) \ 1278 || (SCHEME_NP_CHAPERONEP(obj) && SCHEME_HASHTP(SCHEME_CHAPERONE_VAL(obj)))) 1279 #define SCHEME_CHAPERONE_HASHTRP(obj) (SCHEME_HASHTRP(obj) \ 1280 || (SCHEME_NP_CHAPERONEP(obj) && SCHEME_HASHTRP(SCHEME_CHAPERONE_VAL(obj)))) 1281 #define SCHEME_CHAPERONE_BUCKTP(obj) (SCHEME_BUCKTP(obj) \ 1282 || (SCHEME_NP_CHAPERONEP(obj) && SCHEME_BUCKTP(SCHEME_CHAPERONE_VAL(obj)))) 1283 #define SCHEME_CHAPERONE_PROMPT_TAGP(obj) (SCHEME_PROMPT_TAGP(obj) \ 1284 || (SCHEME_NP_CHAPERONEP(obj) && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(obj)))) 1285 #define SCHEME_CHAPERONE_CONTINUATION_MARK_KEYP(obj) (SCHEME_CONTINUATION_MARK_KEYP(obj) \ 1286 || (SCHEME_NP_CHAPERONEP(obj) \ 1287 && SCHEME_CONTINUATION_MARK_KEYP(SCHEME_CHAPERONE_VAL(obj)))) 1288 1289 #define SCHEME_CHAPERONE_VEC_SIZE(obj) (SCHEME_NP_CHAPERONEP(obj) ? SCHEME_VEC_SIZE(SCHEME_CHAPERONE_VAL(obj)) : SCHEME_VEC_SIZE(obj)) 1290 1291 Scheme_Object *scheme_chaperone_vector_ref(Scheme_Object *o, int i); 1292 void scheme_chaperone_vector_set(Scheme_Object *o, int i, Scheme_Object *v); 1293 1294 Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv, 1295 Scheme_Object *auto_val, int checks); 1296 1297 Scheme_Object *scheme_parse_chaperone_props(const char *who, int start_at, int argc, Scheme_Object **argv); 1298 Scheme_Object *scheme_chaperone_props_get(Scheme_Object *props, Scheme_Object *prop); 1299 Scheme_Object *scheme_chaperone_props_remove(Scheme_Object *props, Scheme_Object *prop); 1300 1301 Scheme_Object *scheme_chaperone_hash_get(Scheme_Object *table, Scheme_Object *key); 1302 Scheme_Object *scheme_chaperone_hash_get_key(Scheme_Object *table, Scheme_Object *key); 1303 Scheme_Object *scheme_chaperone_hash_traversal_get(Scheme_Object *table, Scheme_Object *key, Scheme_Object **alt_key); 1304 void scheme_chaperone_hash_set(Scheme_Object *table, Scheme_Object *key, Scheme_Object *val); 1305 1306 Scheme_Object *scheme_chaperone_not_undefined(Scheme_Object *orig_val); 1307 1308 int scheme_is_noninterposing_chaperone(Scheme_Object *obj); 1309 1310 Scheme_Object *scheme_apply_impersonator_of(int for_chaperone, Scheme_Object *procs, Scheme_Object *obj); 1311 1312 /*========================================================================*/ 1313 /* syntax objects */ 1314 /*========================================================================*/ 1315 1316 /* The internal variant of a syntax object just has a source location 1317 and other properties. */ 1318 1319 typedef struct Scheme_Stx_Srcloc { 1320 MZTAG_IF_REQUIRED 1321 intptr_t line, col, pos, span; 1322 Scheme_Object *src; 1323 } Scheme_Stx_Srcloc; 1324 1325 typedef struct Scheme_Stx { 1326 Scheme_Object so; 1327 Scheme_Object *val; 1328 Scheme_Stx_Srcloc *srcloc; 1329 Scheme_Hash_Tree *props; 1330 } Scheme_Stx; 1331 1332 Scheme_Object *scheme_make_stx(Scheme_Object *val, 1333 Scheme_Stx_Srcloc *srcloc, 1334 Scheme_Hash_Tree *props); 1335 Scheme_Object *scheme_make_stx_w_offset(Scheme_Object *val, 1336 intptr_t line, intptr_t col, intptr_t pos, intptr_t span, 1337 Scheme_Object *src, 1338 Scheme_Hash_Tree *props); 1339 1340 #define DTS_COPY_PROPS 0x1 1341 #define DTS_CAN_GRAPH 0x2 1342 #define DTS_RECUR 0x4 1343 1344 Scheme_Object *scheme_datum_to_syntax(Scheme_Object *o, Scheme_Object *stx_src, int flags); 1345 1346 Scheme_Object *scheme_syntax_to_datum(Scheme_Object *stx); 1347 1348 Scheme_Object *scheme_checked_syntax_e(int argc, Scheme_Object **argv); 1349 1350 Scheme_Object *scheme_stx_property(Scheme_Object *_stx, 1351 Scheme_Object *key, 1352 Scheme_Object *val); 1353 1354 int scheme_stx_list_length(Scheme_Object *list); 1355 int scheme_stx_proper_list_length(Scheme_Object *list); 1356 1357 Scheme_Object *scheme_resolve_placeholders(Scheme_Object *obj); 1358 1359 #define SCHEME_STX_VAL(s) ((Scheme_Stx *)s)->val 1360 1361 #define SCHEME_STX_PAIRP(o) (SCHEME_PAIRP(o) || (SCHEME_STXP(o) && SCHEME_PAIRP(SCHEME_STX_VAL(o)))) 1362 #define SCHEME_STX_SYMBOLP(o) (SCHEME_SYMBOLP(o) || ((SCHEME_STXP(o) && SCHEME_SYMBOLP(SCHEME_STX_VAL(o))))) 1363 #define SCHEME_STX_NULLP(o) (SCHEME_NULLP(o) || (SCHEME_STXP(o) && SCHEME_NULLP(SCHEME_STX_VAL(o)))) 1364 1365 #define SCHEME_STX_CAR(o) (SCHEME_PAIRP(o) ? SCHEME_CAR(o) : SCHEME_CAR(SCHEME_STX_VAL(o))) 1366 #define SCHEME_STX_CDR(o) (SCHEME_PAIRP(o) ? SCHEME_CDR(o) : SCHEME_CDR(SCHEME_STX_VAL(o))) 1367 #define SCHEME_STX_CADR(o) (SCHEME_PAIRP(o) ? SCHEME_STX_CAR(SCHEME_CDR(o)) : SCHEME_STX_CAR(SCHEME_CDR(SCHEME_STX_VAL(o)))) 1368 #define SCHEME_STX_SYM(o) (SCHEME_STXP(o) ? SCHEME_STX_VAL(o) : o) 1369 1370 Scheme_Object *scheme_source_to_name(Scheme_Object *code); 1371 1372 #define STX_SRCTAG scheme_source_stx_props 1373 1374 Scheme_Object *scheme_transfer_srcloc(Scheme_Object *to, Scheme_Object *from); 1375 1376 int scheme_is_predefined_module_p(Scheme_Object *name); 1377 1378 /*========================================================================*/ 1379 /* syntax run-time structures */ 1380 /*========================================================================*/ 1381 1382 /* A Scheme_IR_Local record represents a local variable, where 1383 both the binding and references to that same binding are 1384 represented by the same allocated object. When inlining 1385 or other transformations duplicate a variable, a new instance 1386 is allocated to represent a separate variable. Different passes 1387 in the comiler store different information about the variable. */ 1388 typedef struct Scheme_IR_Local 1389 { 1390 Scheme_Object so; 1391 1392 /* The `mode` value is one of `SCHEME_VAR_MODE_NONE`, etc., 1393 and it determines which of the union cases below (if any) 1394 is active, corresponding to information for a particular 1395 pass: */ 1396 unsigned int mode : 3; 1397 /* Number of time the variable was referenced as counted by 1398 the initial compile phase; a `SCHEME_USE_COUNT_INF` 1399 value corresponds to "more than we counted": */ 1400 unsigned int use_count : 3; 1401 /* Subset of `use_count` references that are in non-rator 1402 positions: */ 1403 unsigned int non_app_count : 3; 1404 /* Records whether the variable is mutated; set in several 1405 phases, and currently never unset: */ 1406 unsigned int mutated : 1; 1407 /* Records whether the optimizer discovered any uses; 1408 if true, then `use_count` must be non-zero, but the 1409 optimizer eliminate references and produce 0 here even 1410 if `use_count` is non-zero: */ 1411 unsigned int optimize_used : 1; 1412 /* Set while compiling the right-hand side of a letrec 1413 to indicate that current and later left-hand sides 1414 are not yet initialized: */ 1415 unsigned int optimize_unready : 1; 1416 /* After optimizing a `let[rec]` form, we might still go into 1417 the body (e.g., for function inlining), but mark the variable 1418 as having a binding set up: */ 1419 unsigned int optimize_outside_binding : 1; 1420 /* Records an anlaysis during the resolve pass: */ 1421 unsigned int resolve_omittable : 1; 1422 /* Records whether the variable is mutated and used before 1423 the body of its binding, so that itmust be allocated at latest 1424 after it's RHS expression is evaluated: */ 1425 unsigned int must_allocate_immediately : 1; 1426 /* The type desired by use positions for unboxing purposes; 1427 set by the optimizer: */ 1428 unsigned int arg_type : SCHEME_MAX_LOCAL_TYPE_BITS; 1429 /* The type provided by the binding position, mainly for unboxing 1430 purposes; set by the optimizer and potentially refined by the 1431 resolve pass (especially for function arguments whose types are 1432 set via local_type_map): */ 1433 unsigned int val_type : SCHEME_MAX_LOCAL_TYPE_BITS; 1434 /* Unboxing might be disabled because allocation of boxes would 1435 be moved past a continuation: */ 1436 unsigned int escapes_after_k_tick : 1; 1437 /* During unresolve, indicates whether references should be 1438 converted to calls: */ 1439 unsigned int is_ref_arg : 1; 1440 1441 Scheme_Object *name; 1442 1443 /* `mode` determines which union is active: */ 1444 union { 1445 struct { 1446 /* To detect uses on right-hand sides in `letrec` */ 1447 int *use_box; 1448 int use_position; 1449 int keep_assignment; /* don't optimize away an assignment to this variable */ 1450 } compile; 1451 struct { 1452 /* Maps the variable into the letrec-check pass's frames: */ 1453 struct Letrec_Check_Frame *frame; 1454 int frame_pos; 1455 } letrec_check; 1456 struct { 1457 /* Constant- and copy-propagation information: */ 1458 Scheme_Object *known_val; 1459 /* Whether `known_val` must be cleared when the variable's 1460 only use is duplicated: */ 1461 int clear_known_on_multi_use; 1462 /* Number of `lambda` wrappers, which is relevant for 1463 accumulating closures, etc.: */ 1464 int lambda_depth; 1465 /* Vitual continuation-capture clock for the variable's 1466 initialation, used to detect potential captures of 1467 allocation: */ 1468 int init_kclock; 1469 /* Transitive uses record uses that become used if 1470 the variable itself is used; which is relevant 1471 for analyzing a letrec-bound function that might 1472 not get called: */ 1473 Scheme_Hash_Table *transitive_uses; 1474 } optimize; 1475 struct { 1476 /* Records the position where the variable will be 1477 on the runstack, counting down from the enclosing 1478 procedure's starting point (i.e., backwards from the 1479 run-time direction): */ 1480 int co_depth; 1481 /* Records a lexical depth for the purposes of sorting 1482 variables (as needed to make compilation deterministic): */ 1483 int lex_depth; 1484 /* Information on closure-converstion of this 1485 variable's binding: */ 1486 Scheme_Object *lifted; 1487 } resolve; 1488 }; 1489 } Scheme_IR_Local; 1490 1491 #define SCHEME_VAR(v) ((Scheme_IR_Local *)v) 1492 1493 #define SCHEME_USE_COUNT_INF 7 1494 1495 #define SCHEME_VAR_MODE_NONE 0 1496 #define SCHEME_VAR_MODE_COMPILE 1 1497 #define SCHEME_VAR_MODE_LETREC_CHECK 2 1498 #define SCHEME_VAR_MODE_OPTIMIZE 3 1499 #define SCHEME_VAR_MODE_RESOLVE 4 1500 1501 /* Definition and references share the same object during the 1502 "compile" pass, and SCHEME_IR_TOPLEVEL_MUTATED is set in that pass. 1503 During the "optimize" pass, references may be cloned to set 1504 SCHEME_TOPLEVEL_CONST, etc. */ 1505 typedef struct Scheme_IR_Toplevel 1506 { 1507 Scheme_Inclhash_Object iso; /* scheme_import_export_variable_type; not hashable */ 1508 int instance_pos; /* import instance position, or -1 for exported and internal */ 1509 int variable_pos; /* position within import instance or definition sequence */ 1510 } Scheme_IR_Toplevel; 1511 1512 /* See also SCHEME_TOPLEVEL_... */ 1513 #define SCHEME_IR_TOPLEVEL_MUTATED 0x4 1514 1515 #define SCHEME_IR_TOPLEVEL_FLAGS(var) MZ_OPT_HASH_KEY(&(var)->iso) 1516 #define SCHEME_IR_TOPLEVEL_INSTANCE(var) (((Scheme_IR_Toplevel *)var)->instance_pos) 1517 #define SCHEME_IR_TOPLEVEL_POS(var) (((Scheme_IR_Toplevel *)var)->variable_pos) 1518 1519 /* Number of runstack slots before imports: */ 1520 #define SCHEME_LINKLET_PREFIX_PREFIX 1 1521 1522 Scheme_IR_Toplevel *scheme_make_ir_toplevel(int instance_pos, int variable_pos, int flags); 1523 Scheme_Object *scheme_ir_toplevel_to_flagged_toplevel(Scheme_Object *tl, int flags); 1524 1525 typedef struct { 1526 Scheme_Inclhash_Object iso; /* keyex used for flags */ 1527 mzshort num_args; /* doesn't include rator, so arguments are at args[1]...args[num_args] */ 1528 Scheme_Object *args[mzFLEX_ARRAY_DECL]; 1529 /* After array of f & args, array of chars for eval type */ 1530 } Scheme_App_Rec; 1531 1532 #define SCHEME_APPN_FLAGS(app) MZ_OPT_HASH_KEY(&(app)->iso) 1533 /* For all application types, throgh optimization, the low bits of the flags 1534 are used to hold an index for an application indicate that it's the Nth 1535 application of an identifier, which is useful to type inference. 1536 The same bits are used after resolve for app2 and app3 to indicate 1537 lookahead types (as below) */ 1538 1539 /* A value of N means that the application is the (N-1)th 1540 application of a variable, where 0 means "unknown". */ 1541 #define APPN_POSITION_MASK SCHEME_USE_COUNT_INF 1542 1543 /* Lookahead types for evaluating application arguments. */ 1544 /* 4 cases + else => magic number for some compilers doing a switch? */ 1545 enum { 1546 SCHEME_EVAL_CONSTANT = 0, 1547 SCHEME_EVAL_GLOBAL, 1548 SCHEME_EVAL_LOCAL, 1549 SCHEME_EVAL_LOCAL_UNBOX, 1550 SCHEME_EVAL_GENERAL 1551 }; 1552 1553 /* Flags to indicate to SFS pass that a [tail] application doesn't 1554 need clearing before it (because the call is to a immediate 1555 primitive or a Racket-implemented function). */ 1556 #define APPN_FLAG_SFS_TAIL (1 << 13) 1557 #define APPN_FLAG_IMMED (1 << 12) 1558 /* The compiler may determine that a call is omittable; usually that 1559 information is encoded in the primitive itself, but sometimes the 1560 optimizer can figure out more (e.g., based on known types of the 1561 arguments): */ 1562 #define APPN_FLAG_OMITTABLE (1 << 11) 1563 #define APPN_FLAG_MASK (APPN_FLAG_OMITTABLE | APPN_FLAG_IMMED | APPN_FLAG_SFS_TAIL) 1564 1565 typedef struct { 1566 Scheme_Inclhash_Object iso; /* keyex used for flags */ 1567 Scheme_Object *rator; 1568 Scheme_Object *rand; 1569 } Scheme_App2_Rec; 1570 1571 typedef struct { 1572 Scheme_Inclhash_Object iso; /* keyex used for flags */ 1573 Scheme_Object *rator; 1574 Scheme_Object *rand1; 1575 Scheme_Object *rand2; 1576 } Scheme_App3_Rec; 1577 1578 typedef struct { 1579 Scheme_Object so; 1580 Scheme_Object *test; 1581 Scheme_Object *tbranch; 1582 Scheme_Object *fbranch; 1583 } Scheme_Branch_Rec; 1584 1585 /* A `let' or `letrec' form is compiled to the intermediate 1586 format (used during the optimization pass) as a Scheme_IR_Let_Header 1587 with a chain of Scheme_IR_Let_Value records as its body, 1588 where there's one Scheme_IR_Let_Value for each binding 1589 clause. The body of the `let...' form is the body of the innermost 1590 Scheme_IR_Let_Value record. 1591 */ 1592 1593 typedef struct Scheme_IR_Let_Header { 1594 Scheme_Inclhash_Object iso; /* keyex used for recursive */ 1595 mzshort count; /* total number of bindings */ 1596 mzshort num_clauses; /* number of binding clauses */ 1597 Scheme_Object *body; 1598 } Scheme_IR_Let_Header; 1599 1600 #define SCHEME_LET_FLAGS(lh) MZ_OPT_HASH_KEY(&lh->iso) 1601 #define SCHEME_LET_RECURSIVE 0x1 1602 1603 typedef struct Scheme_IR_Let_Value { 1604 Scheme_Inclhash_Object iso; /* keyex used for set-starting */ 1605 mzshort count; 1606 Scheme_Object *value; 1607 Scheme_Object *body; 1608 Scheme_IR_Local **vars; 1609 } Scheme_IR_Let_Value; 1610 1611 #define SCHEME_IRLV_FLAGS(irlv) MZ_OPT_HASH_KEY(&(irlv)->iso) 1612 #define SCHEME_IRLV_NO_GROUP_LATER_USES 0x1 1613 #define SCHEME_IRLV_NO_GROUP_USES 0x2 1614 1615 typedef struct { 1616 Scheme_Object so; 1617 Scheme_Object *key; 1618 Scheme_Object *val; 1619 Scheme_Object *body; 1620 } Scheme_With_Continuation_Mark; 1621 1622 #define HIGH_BIT_TO_DISABLE_HASHING 0x2000 1623 1624 typedef struct Scheme_Local { 1625 Scheme_Inclhash_Object iso; /* keyex used for flags and type info (and can't be hashed) */ 1626 mzshort position; 1627 #ifdef MZ_PRECISE_GC 1628 # ifdef MZSHORT_IS_SHORT 1629 /* Everything has to be at least 2 words in size. */ 1630 int x; 1631 # endif 1632 #endif 1633 } Scheme_Local; 1634 1635 #define SCHEME_LOCAL_POS(obj) (((Scheme_Local *)(obj))->position) 1636 #define SCHEME_LOCAL_FLAGS(obj) MZ_OPT_HASH_KEY(&((Scheme_Local *)(obj))->iso) 1637 1638 #define SCHEME_LOCAL_CLEAR_ON_READ 1 1639 #define SCHEME_LOCAL_OTHER_CLEARS 2 1640 #define SCHEME_LOCAL_TYPE_OFFSET 2 1641 1642 #define SCHEME_GET_LOCAL_FLAGS(obj) (SCHEME_LOCAL_FLAGS(obj) & ~HIGH_BIT_TO_DISABLE_HASHING) 1643 #define SCHEME_GET_LOCAL_TYPE(obj) ((SCHEME_GET_LOCAL_FLAGS(obj) > 2) ? (SCHEME_GET_LOCAL_FLAGS(obj) - 2) : 0) 1644 1645 typedef struct Scheme_Toplevel { 1646 Scheme_Inclhash_Object iso; /* keyex used for flags (and can't be hashed) */ 1647 union { 1648 mzshort depth; /* normal mode */ 1649 struct Scheme_Prefix *prefix; /* for a linklet that is only instantiated once */ 1650 } u; 1651 int position; 1652 } Scheme_Toplevel; 1653 1654 #define SCHEME_TOPLEVEL_DEPTH(obj) (((Scheme_Toplevel *)(obj))->u.depth) 1655 #define SCHEME_STATIC_TOPLEVEL_PREFIX(obj) (((Scheme_Toplevel *)(obj))->u.prefix) 1656 #define SCHEME_TOPLEVEL_POS(obj) (((Scheme_Toplevel *)(obj))->position) 1657 #define SCHEME_TOPLEVEL_FLAGS(obj) MZ_OPT_HASH_KEY(&((Scheme_Toplevel *)(obj))->iso) 1658 1659 /* The MASK pull out one of the levels for reference (CONST, 1660 FIXED, READY, or UNKNOWN) or one of the two levels for a 1661 definition (SEAL or not) */ 1662 #define SCHEME_TOPLEVEL_FLAGS_MASK 0x3 1663 #define SCHEME_LOG_TOPLEVEL_FLAG_MASK 2 1664 1665 /* CONST means that a toplevel is READY and always has the "same" value, 1666 even for different instantiations or phases. "Same" means that the result 1667 is a procedure or would be ok to duplicate in the source. */ 1668 #define SCHEME_TOPLEVEL_CONST 3 1669 /* FIXED is READY plus a promise of no mutation, but the value is 1670 not necessarily constant across different instantations or phases. */ 1671 #define SCHEME_TOPLEVEL_FIXED 2 1672 /* READY means that the toplevel will have a value (i.e., the variable 1673 is defined), though it might be mutated later */ 1674 #define SCHEME_TOPLEVEL_READY 1 1675 /* UNKNOWN means that the variable might not even be defined by the time the 1676 toplevel reference is executed */ 1677 #define SCHEME_TOPLEVEL_UNKNOWN 0 1678 1679 #define SCHEME_TOPLEVEL_SEAL 0x1 1680 1681 /* MUTATED is used on the toplevel for a definition, and only until 1682 after resolving; it records whether a toplevel is `set!'ed */ 1683 #define SCHEME_TOPLEVEL_MUTATED 0x4 1684 1685 typedef struct Scheme_Quote_Syntax { 1686 Scheme_Object so; /* scheme_quote_syntax_type */ 1687 mzshort depth; 1688 mzshort position; 1689 mzshort midpoint; 1690 } Scheme_Quote_Syntax; 1691 1692 typedef struct Scheme_Let_Value { 1693 Scheme_Inclhash_Object iso; /* keyex used for autobox */ 1694 mzshort count; 1695 mzshort position; 1696 Scheme_Object *value; 1697 Scheme_Object *body; 1698 } Scheme_Let_Value; 1699 1700 #define SCHEME_LET_VALUE_AUTOBOX(lv) MZ_OPT_HASH_KEY(&lv->iso) 1701 1702 typedef struct Scheme_Let_One { 1703 Scheme_Inclhash_Object iso; /* keyex used for eval_type + flonum/unused (and can't be hashed) */ 1704 Scheme_Object *value; 1705 Scheme_Object *body; 1706 } Scheme_Let_One; 1707 1708 #define SCHEME_LET_EVAL_TYPE(lh) MZ_OPT_HASH_KEY(&lh->iso) 1709 #define LET_ONE_UNUSED 0x8 1710 1711 #define LET_ONE_TYPE_SHIFT 4 1712 #define LET_ONE_TYPE_MASK (SCHEME_MAX_LOCAL_TYPE_MASK << 4) 1713 #define SCHEME_LET_ONE_TYPE(lo) (SCHEME_LET_EVAL_TYPE(lo) >> LET_ONE_TYPE_SHIFT) 1714 1715 typedef struct Scheme_Let_Void { 1716 Scheme_Inclhash_Object iso; /* keyex used for autobox */ 1717 mzshort count; 1718 Scheme_Object *body; 1719 } Scheme_Let_Void; 1720 1721 #define SCHEME_LET_VOID_AUTOBOX(lv) MZ_OPT_HASH_KEY(&lv->iso) 1722 1723 typedef struct Scheme_Letrec { 1724 Scheme_Object so; 1725 mzshort count; 1726 Scheme_Object **procs; 1727 Scheme_Object *body; 1728 } Scheme_Letrec; 1729 1730 typedef struct { 1731 Scheme_Object so; 1732 mzshort count; 1733 Scheme_Object *array[mzFLEX_ARRAY_DECL]; 1734 } Scheme_Sequence; 1735 1736 typedef struct { 1737 Scheme_Object so; 1738 mzshort count; 1739 Scheme_Object *name; /* see note below */ 1740 #ifdef MZ_USE_JIT 1741 struct Scheme_Native_Lambda *native_code; /* generated by lightning */ 1742 #endif 1743 Scheme_Object *array[mzFLEX_ARRAY_DECL]; 1744 } Scheme_Case_Lambda; 1745 /* If count is not 0, then check array[0] for LAMBDA_IS_METHOD. 1746 Otherwise, name is a boxed symbol (or #f) to indicate a method. */ 1747 1748 #define scheme_make_prim_w_arity2(f, n, mina, maxa, minr, maxr) \ 1749 scheme_make_prim_w_everything(f, 1, n, mina, maxa, 0, minr, maxr) 1750 1751 Scheme_Object *scheme_unclose_case_lambda(Scheme_Object *expr, int jit); 1752 1753 Scheme_Object *scheme_native_stack_trace(void); 1754 void scheme_clean_native_symtab(void); 1755 void scheme_clean_cust_box_list(void); 1756 #ifndef MZ_PRECISE_GC 1757 void scheme_notify_code_gc(void); 1758 #endif 1759 1760 #ifdef USE_THREAD_LOCAL 1761 # define BOTTOM_VARIABLE GC_variable_stack 1762 # define EXTRA_NATIVE_ARGUMENT , &BOTTOM_VARIABLE 1763 # define EXTRA_NATIVE_ARGUMENT_TYPE , void* thdloc 1764 #else 1765 # define EXTRA_NATIVE_ARGUMENT /* empty */ 1766 # define EXTRA_NATIVE_ARGUMENT_TYPE /* empty */ 1767 #endif 1768 1769 typedef struct Scheme_Object *(Scheme_Native_Proc)(void *d, int argc, struct Scheme_Object *argv[] 1770 EXTRA_NATIVE_ARGUMENT_TYPE); 1771 1772 /*========================================================================*/ 1773 /* control flow */ 1774 /*========================================================================*/ 1775 1776 Scheme_Object *scheme_handle_stack_overflow(Scheme_Object *(*k)(void)); 1777 int scheme_is_stack_too_shallow(); 1778 1779 THREAD_LOCAL_DECL(extern struct Scheme_Overflow_Jmp *scheme_overflow_jmp); 1780 THREAD_LOCAL_DECL(extern void *scheme_overflow_stack_start); 1781 1782 #ifdef MZ_PRECISE_GC 1783 # define PROMPT_STACK(id) &__gc_var_stack__ 1784 #else 1785 # define PROMPT_STACK(id) ((void *)(&id)) 1786 #endif 1787 1788 struct Scheme_Overflow_Jmp *scheme_prune_jmpup(struct Scheme_Overflow_Jmp *jmp, void *stack_boundary); 1789 1790 void scheme_jmpup_free(Scheme_Jumpup_Buf *); 1791 void *scheme_enlarge_runstack(intptr_t size, void *(*k)()); 1792 int scheme_check_runstack(intptr_t size); 1793 1794 #ifndef MZ_PRECISE_GC 1795 void scheme_init_setjumpup(void); 1796 void scheme_init_ephemerons(void); 1797 #endif 1798 1799 #ifdef MZ_PRECISE_GC 1800 void scheme_flush_stack_copy_cache(void); 1801 #endif 1802 1803 void *scheme_top_level_do(void *(*k)(void), int eb); 1804 void *scheme_top_level_do_worker(void *(*k)(void), int eb, int newthread); 1805 1806 Scheme_Object *scheme_call_ec(int argc, Scheme_Object *argv[]); 1807 1808 uintptr_t scheme_get_deeper_address(void); 1809 1810 #ifdef DO_STACK_CHECK 1811 void scheme_init_stack_limit (void); 1812 #endif 1813 1814 1815 typedef struct Scheme_Saved_Stack { 1816 MZTAG_IF_REQUIRED 1817 Scheme_Object **runstack_start; 1818 intptr_t runstack_offset; 1819 intptr_t runstack_size; 1820 struct Scheme_Saved_Stack *prev; 1821 } Scheme_Saved_Stack; 1822 1823 typedef struct Scheme_Cont_Mark { 1824 /* Precise GC: We leave out the tag and make sure everything 1825 is a pointer, then allocate with GC_malloc_allow_interior */ 1826 Scheme_Object *key; 1827 Scheme_Object *val; 1828 Scheme_Object *cache; /* chain and/or shortcut */ 1829 MZ_MARK_POS_TYPE pos; /* Odd numbers - so they look like non-pointers */ 1830 } Scheme_Cont_Mark; 1831 #define LOG_CONT_MARK_WORD_COUNT 2 1832 1833 void scheme_new_mark_segment(Scheme_Thread *p); 1834 1835 typedef struct Scheme_Cont_Mark_Chain { 1836 Scheme_Inclhash_Object iso; /* 0x1 => next is from different meta-continuation */ 1837 Scheme_Object *key; 1838 Scheme_Object *val; 1839 MZ_MARK_POS_TYPE pos; 1840 struct Scheme_Cont_Mark_Chain *next; 1841 } Scheme_Cont_Mark_Chain; 1842 1843 #define SCHEME_MARK_CHAIN_FLAG(c) MZ_OPT_HASH_KEY(&(c)->iso) 1844 1845 typedef struct Scheme_Cont_Mark_Set { 1846 Scheme_Object so; 1847 struct Scheme_Cont_Mark_Chain *chain; 1848 intptr_t cmpos; 1849 Scheme_Object *native_stack_trace; 1850 } Scheme_Cont_Mark_Set; 1851 1852 #define SCHEME_LOG_MARK_SEGMENT_SIZE 6 1853 #define SCHEME_MARK_SEGMENT_SIZE (1 << SCHEME_LOG_MARK_SEGMENT_SIZE) 1854 #define SCHEME_MARK_SEGMENT_MASK (SCHEME_MARK_SEGMENT_SIZE - 1) 1855 1856 typedef struct Scheme_Stack_State { 1857 intptr_t runstack_offset; 1858 MZ_MARK_POS_TYPE cont_mark_pos; 1859 MZ_MARK_STACK_TYPE cont_mark_stack; 1860 } Scheme_Stack_State; 1861 1862 typedef struct Scheme_Dynamic_Wind { 1863 MZTAG_IF_REQUIRED 1864 int depth; 1865 void *id; /* generated as needed */ 1866 void *data; 1867 Scheme_Object *prompt_tag; /* If not NULL, indicates a fake D-W record for prompt boundary */ 1868 void (*pre)(void *); 1869 void (*post)(void *); 1870 mz_jmp_buf *saveerr; 1871 int next_meta; /* amount to move forward in the meta-continuation chain, starting with next */ 1872 struct Scheme_Stack_State envss; 1873 struct Scheme_Dynamic_Wind *prev; 1874 } Scheme_Dynamic_Wind; 1875 1876 typedef struct Scheme_Cont_Jmp { 1877 MZTAG_IF_REQUIRED 1878 Scheme_Jumpup_Buf buf; 1879 } Scheme_Cont_Jmp; 1880 1881 typedef struct Scheme_Cont { 1882 Scheme_Object so; 1883 char composable, has_prompt_dw, need_meta_prompt, skip_dws; 1884 struct Scheme_Meta_Continuation *meta_continuation; 1885 Scheme_Object *meta_continuation_src; /* a weak reference to the mc cloned, for use in detecting sharing */ 1886 Scheme_Cont_Jmp *buf_ptr; /* indirection allows sharing */ 1887 Scheme_Dynamic_Wind *dw; 1888 int next_meta; 1889 Scheme_Continuation_Jump_State cjs; 1890 Scheme_Stack_State ss; 1891 struct Scheme_Prompt *barrier_prompt; /* NULL if no barrier between cont and prompt */ 1892 Scheme_Object **runstack_start; 1893 intptr_t runstack_size; 1894 Scheme_Saved_Stack *runstack_saved; 1895 Scheme_Object *prompt_tag; 1896 mz_jmp_buf *prompt_buf; /* needed for meta-prompt */ 1897 MZ_MARK_POS_TYPE meta_tail_pos; /* to recognize opportunity for meta-tail calls */ 1898 MZ_MARK_POS_TYPE cont_mark_pos_bottom; /* to splice cont mark values with meta-cont */ 1899 void *prompt_stack_start; 1900 Scheme_Saved_Stack *runstack_copied; 1901 Scheme_Thread **runstack_owner; 1902 Scheme_Cont_Mark *cont_mark_stack_copied; 1903 Scheme_Thread **cont_mark_stack_owner; 1904 intptr_t cont_mark_total; /* size of the copied array plus cont_mark_offset */ 1905 intptr_t cont_mark_offset; /* after the array, the original mark stack had this much */ 1906 intptr_t cont_mark_nonshare; /* amount to skip for sub-cont sharing */ 1907 void *stack_start; 1908 Scheme_Object *prompt_id; /* allows direct-jump optimization */ 1909 Scheme_Config *init_config; 1910 Scheme_Object *init_break_cell; 1911 #ifdef MZ_USE_JIT 1912 Scheme_Object *native_trace; 1913 #endif 1914 struct Scheme_Overflow *save_overflow; 1915 mz_jmp_buf *savebuf; /* save old error buffer here */ 1916 1917 Scheme_Object *escape_cont; 1918 int orig_escape_cont; 1919 1920 /* Arguments passed to a continuation invocation to the continuation restorer: */ 1921 Scheme_Object *value; /* argument(s) to continuation */ 1922 struct Scheme_Overflow *resume_to; /* meta-continuation return */ 1923 char empty_to_next_mc; 1924 struct Scheme_Cont *use_next_cont; /* more meta-continuation return */ 1925 int common_dw_depth; /* id for common dw record */ 1926 Scheme_Dynamic_Wind *common_dw; /* shared part with source cont */ 1927 int common_next_meta; /* for common_dw */ 1928 Scheme_Object *extra_marks; /* vector of extra keys and marks to add to meta-cont */ 1929 struct Scheme_Prompt *shortcut_prompt; /* prompt common to save and restore enabling shortcut */ 1930 } Scheme_Cont; 1931 1932 typedef struct Scheme_Escaping_Cont { 1933 Scheme_Object so; 1934 struct Scheme_Stack_State envss; 1935 struct Scheme_Prompt *barrier_prompt; 1936 #ifdef MZ_USE_JIT 1937 Scheme_Object *native_trace; 1938 #endif 1939 mz_jmp_buf *saveerr, *myerr; 1940 } Scheme_Escaping_Cont; 1941 1942 #define SCHEME_CONT_F(obj) (((Scheme_Escaping_Cont *)(obj))->f) 1943 1944 int scheme_escape_continuation_ok(Scheme_Object *); 1945 1946 #define scheme_save_env_stack_w_thread(ss, p) \ 1947 (ss.runstack_offset = MZ_RUNSTACK - MZ_RUNSTACK_START, \ 1948 ss.cont_mark_stack = MZ_CONT_MARK_STACK, ss.cont_mark_pos = MZ_CONT_MARK_POS) 1949 #define scheme_restore_env_stack_w_thread(ss, p) \ 1950 (MZ_RUNSTACK = MZ_RUNSTACK_START + ss.runstack_offset, \ 1951 MZ_CONT_MARK_STACK = ss.cont_mark_stack, MZ_CONT_MARK_POS = ss.cont_mark_pos) 1952 #define scheme_save_env_stack(ss) \ 1953 scheme_save_env_stack_w_thread(ss, scheme_current_thread) 1954 #define scheme_restore_env_stack(ss) \ 1955 scheme_restore_env_stack_w_thread(ss, scheme_current_thread) 1956 1957 void scheme_takeover_stacks(Scheme_Thread *p); 1958 1959 typedef struct Scheme_Overflow_Jmp { 1960 MZTAG_IF_REQUIRED 1961 char captured; /* set to 1 if possibly captured in a continuation */ 1962 Scheme_Jumpup_Buf cont; /* continuation after value obtained in overflowed */ 1963 mz_jmp_buf *savebuf; /* save old error buffer pointer here */ 1964 } Scheme_Overflow_Jmp; 1965 1966 typedef struct Scheme_Overflow { 1967 MZTAG_IF_REQUIRED 1968 char eot; /* set to 1 => pseudo-overflow: continuation is to exit the thread */ 1969 Scheme_Overflow_Jmp *jmp; /* overflow data, so it can be shared when an overflow chain is cloned; */ 1970 void *id; /* identity of overflow record; generated as needed, and often == jmp */ 1971 void *stack_start; 1972 struct Scheme_Overflow *prev; /* old overflow info */ 1973 } Scheme_Overflow; 1974 1975 #if defined(UNIX_FIND_STACK_BOUNDS) || defined(WINDOWS_FIND_STACK_BOUNDS) \ 1976 || defined(MACOS_FIND_STACK_BOUNDS) || defined(ASSUME_FIXED_STACK_SIZE) \ 1977 || defined(PALM_FIND_STACK_BOUNDS) || defined(PTHREAD_STACKSEG_FIND_STACK_BOUNDS) 1978 # define USE_STACK_BOUNDARY_VAR 1979 THREAD_LOCAL_DECL(extern uintptr_t scheme_stack_boundary); 1980 /* Same as scheme_stack_boundary, but set to an extreme value when feul auto-expires, 1981 so that JIT-generated code can check just one variable: */ 1982 THREAD_LOCAL_DECL(extern uintptr_t volatile scheme_jit_stack_boundary); 1983 #endif 1984 1985 typedef struct Scheme_Meta_Continuation { 1986 MZTAG_IF_REQUIRED 1987 char pseudo; /* if set, don't treat it as a prompt */ 1988 char empty_to_next; /* when pseudo, if the continuation is empty to the next one */ 1989 char cm_caches; /* cached info in copied cm */ 1990 char cm_shared; /* cm is shared, so copy before setting cache entries */ 1991 int copy_after_captured; /* for mutating a meta-continuation in set_cont_stack_mark */ 1992 int depth; 1993 Scheme_Object *prompt_tag; 1994 /* The C stack: */ 1995 Scheme_Overflow *overflow; 1996 MZ_MARK_POS_TYPE meta_tail_pos; /* to recognize opportunity for meta-tail calls */ 1997 MZ_MARK_POS_TYPE cont_mark_pos_bottom; /* to splice cont mark values with meta-cont */ 1998 /* Cont mark info: */ 1999 MZ_MARK_STACK_TYPE cont_mark_stack; 2000 MZ_MARK_POS_TYPE cont_mark_pos; 2001 intptr_t cont_mark_total, cont_mark_offset; 2002 Scheme_Cont_Mark *cont_mark_stack_copied; 2003 /* Continuation (whose cont-mark info is the same as above) */ 2004 struct Scheme_Cont *cont; 2005 /* Next: */ 2006 struct Scheme_Meta_Continuation *next; 2007 } Scheme_Meta_Continuation; 2008 2009 typedef struct Scheme_Prompt { 2010 Scheme_Object so; 2011 char is_barrier, has_chaperone, weak_boundary; 2012 Scheme_Object *tag; 2013 Scheme_Object *id; /* created as needed; allows direct-jump optimization for cont app */ 2014 void *stack_boundary; /* where to stop copying the C stack */ 2015 void *boundary_overflow_id; /* indicates the C stack segment */ 2016 MZ_MARK_STACK_TYPE mark_boundary; /* where to stop copying cont marks */ 2017 MZ_MARK_POS_TYPE boundary_mark_pos; /* mark position of prompt */ 2018 union { 2019 Scheme_Object **runstack_boundary_start; /* which stack has runstack_boundary */ 2020 Scheme_Object *runstack_boundary_start_ref; /* weak-ref variant, used when `weak_boundary` */ 2021 } u; 2022 intptr_t runstack_boundary_offset; /* where to stop copying the Scheme stack */ 2023 mz_jmp_buf *prompt_buf; /* to jump directly to the prompt */ 2024 intptr_t runstack_size; /* needed for restore */ 2025 } Scheme_Prompt; 2026 2027 XFORM_NONGCING Scheme_Object **scheme_prompt_runstack_boundary_start(Scheme_Prompt *p); 2028 2029 /* Compiler helper: */ 2030 #define ESCAPED_BEFORE_HERE return NULL 2031 2032 Scheme_Object *scheme_compose_continuation(Scheme_Cont *c, int num_rands, Scheme_Object *value); 2033 Scheme_Overflow *scheme_get_thread_end_overflow(void); 2034 void scheme_end_current_thread(void); 2035 void scheme_ensure_dw_id(Scheme_Dynamic_Wind *dw); 2036 void scheme_apply_dw_in_meta(Scheme_Dynamic_Wind *dw, int post, int mc_depth, struct Scheme_Cont *recheck); 2037 2038 void scheme_drop_prompt_meta_continuations(Scheme_Object *prompt_tag); 2039 2040 struct Scheme_Prompt *scheme_get_barrier_prompt(struct Scheme_Meta_Continuation **_meta_cont, 2041 MZ_MARK_POS_TYPE *_pos); 2042 Scheme_Prompt *scheme_get_prompt(Scheme_Object *prompt_tag, Scheme_Meta_Continuation **_meta_cont, 2043 MZ_MARK_POS_TYPE *_pos); 2044 int scheme_is_cm_deeper(struct Scheme_Meta_Continuation *m1, MZ_MARK_POS_TYPE p1, 2045 struct Scheme_Meta_Continuation *m2, MZ_MARK_POS_TYPE p2); 2046 void scheme_recheck_prompt_and_barrier(struct Scheme_Cont *c); 2047 2048 Scheme_Object *scheme_all_current_continuation_marks(void); 2049 Scheme_Object *scheme_current_continuation_marks_as(const char *who, Scheme_Object *prompt_tag); 2050 2051 void scheme_about_to_move_C_stack(void); 2052 2053 Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Object **rands, 2054 Scheme_Object **old_runstack, int can_ec); 2055 void scheme_escape_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Object **rands, Scheme_Object *alt_full); 2056 2057 Scheme_Object *scheme_chaperone_do_continuation_mark(const char *name, int is_get, Scheme_Object *key, Scheme_Object *val); 2058 2059 XFORM_NONGCING Scheme_Object *scheme_get_immediate_cc_mark(Scheme_Object *key, Scheme_Object *def_val); 2060 Scheme_Object *scheme_chaperone_get_immediate_cc_mark(Scheme_Object *key, Scheme_Object *def_val); 2061 2062 void scheme_clear_prompt_cache(void); 2063 2064 /*========================================================================*/ 2065 /* semaphores and locks */ 2066 /*========================================================================*/ 2067 2068 typedef struct Scheme_Channel_Syncer { 2069 Scheme_Object so; 2070 Scheme_Thread *p; 2071 char in_line, picked; 2072 struct Scheme_Channel_Syncer *prev, *next; 2073 struct Syncing *syncing; 2074 Scheme_Object *obj; 2075 int syncing_i; 2076 } Scheme_Channel_Syncer; 2077 2078 typedef struct Scheme_Sema { 2079 Scheme_Object so; 2080 Scheme_Channel_Syncer *first, *last; 2081 intptr_t value; 2082 } Scheme_Sema; 2083 2084 typedef struct Scheme_Channel { 2085 Scheme_Object so; 2086 Scheme_Channel_Syncer *put_first, *put_last; 2087 Scheme_Channel_Syncer *get_first, *get_last; 2088 } Scheme_Channel; 2089 2090 typedef struct Scheme_Channel_Put { 2091 Scheme_Object so; 2092 Scheme_Channel *ch; 2093 Scheme_Object *val; 2094 } Scheme_Channel_Put; 2095 2096 #define GENERIC_BLOCKED -1 2097 #define NOT_BLOCKED 0 2098 #define SLEEP_BLOCKED 1 2099 2100 typedef struct Evt_Set { 2101 Scheme_Inclhash_Object iso; /* 0x1 => unflattened */ 2102 int argc; 2103 Scheme_Object **argv; /* no evt sets; nested sets get flattened */ 2104 struct Evt **ws; 2105 } Evt_Set; 2106 2107 #define SCHEME_EVTSETP(o) SAME_TYPE(SCHEME_TYPE(o), scheme_evt_set_type) 2108 #define SCHEME_EVTSET_UNFLATTENEDP(o) SCHEME_IMMUTABLEP(o) 2109 #define SCHEME_SET_EVTSET_UNFLATTENED(o) SCHEME_SET_IMMUTABLE(o) 2110 2111 typedef struct Syncing { 2112 MZTAG_IF_REQUIRED 2113 Evt_Set *set; 2114 int result, start_pos; 2115 double sleep_end; 2116 float timeout; 2117 2118 Scheme_Object **wrapss; 2119 Scheme_Object **nackss; 2120 char *reposts; 2121 Scheme_Accept_Sync *accepts; 2122 2123 Scheme_Thread *disable_break; /* when result is set */ 2124 Scheme_Thread *thread; /* set when syncing to allow in flight place message cleanup */ 2125 } Syncing; 2126 2127 int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *syncing); 2128 Scheme_Object *scheme_make_sema_repost(Scheme_Object *sema); 2129 2130 Scheme_Object *scheme_wrap_evt(int argc, Scheme_Object *argv[]); 2131 Scheme_Object *scheme_poll_evt(int argc, Scheme_Object *argv[]); 2132 2133 Scheme_Object *scheme_do_chaperone_evt(const char*, int, int, Scheme_Object *argv[]); 2134 2135 extern Scheme_Object *scheme_always_ready_evt; 2136 2137 void scheme_get_outof_line(Scheme_Channel_Syncer *ch_w); 2138 void scheme_get_back_into_line(Scheme_Channel_Syncer *ch_w); 2139 void scheme_post_syncing_nacks(Syncing *syncing); 2140 2141 int scheme_try_channel_get(Scheme_Object *ch); 2142 int scheme_try_channel_put(Scheme_Object *ch, Scheme_Object *v); 2143 2144 intptr_t scheme_get_semaphore_init(const char *who, int n, Scheme_Object **p); 2145 2146 /*========================================================================*/ 2147 /* numbers */ 2148 /*========================================================================*/ 2149 2150 #ifdef MPW_C 2151 /* Optimizer bug! */ 2152 # define scheme_exact_zero ((Scheme_Object *)0x1) 2153 # define scheme_exact_one ((Scheme_Object *)0x3) 2154 #else 2155 # define scheme_exact_zero scheme_make_integer(0) 2156 # define scheme_exact_one scheme_make_integer(1) 2157 #endif 2158 2159 #ifdef MZ_LONG_DOUBLE 2160 # define MZ_LONG_DOUBLE_AND(x) (x) 2161 #else 2162 # define MZ_LONG_DOUBLE_AND(x) 0 2163 #endif 2164 2165 #ifdef MZ_LONG_DOUBLE_API_IS_EXTERNAL 2166 # define MZ_LONG_DOUBLE_AVAIL_AND(x) MZ_LONG_DOUBLE_AND(long_double_available() && (x)) 2167 # define WHEN_LONG_DOUBLE_UNSUPPORTED(what) \ 2168 if (!long_double_available()) { \ 2169 what; \ 2170 } 2171 # define CHECK_MZ_LONG_DOUBLE_UNSUPPORTED(who) \ 2172 if (!long_double_available()) { \ 2173 scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, who ": " NOT_SUPPORTED_STR); \ 2174 ESCAPED_BEFORE_HERE; \ 2175 } 2176 #else 2177 # define WHEN_LONG_DOUBLE_UNSUPPORTED(what) /* empty */ 2178 # define CHECK_MZ_LONG_DOUBLE_UNSUPPORTED(who) /* empty */ 2179 # define MZ_LONG_DOUBLE_AVAIL_AND(x) MZ_LONG_DOUBLE_AND(x) 2180 #endif 2181 2182 void scheme_configure_floating_point(void); 2183 2184 extern double scheme_double_too_positive_for_fixnum, scheme_double_too_negative_for_fixnum; 2185 #ifdef MZ_LONG_DOUBLE 2186 extern long_double scheme_extfl_too_positive_for_fixnum, scheme_extfl_too_negative_for_fixnum; 2187 #endif 2188 2189 /****** Bignums *******/ 2190 2191 #ifdef USE_LONG_LONG_FOR_BIGDIG 2192 typedef unsigned long long bigdig; 2193 #else 2194 typedef uintptr_t bigdig; 2195 #endif 2196 2197 typedef struct { 2198 Scheme_Inclhash_Object iso; 2199 intptr_t len; 2200 bigdig *digits; 2201 } Scheme_Bignum; 2202 2203 #ifdef MZ_PRECISE_GC 2204 # define SCHEME_BIGPOS(b) (MZ_OPT_HASH_KEY(&((Scheme_Bignum *)b)->iso) & 0x1) 2205 # define SCHEME_SET_BIGPOS(b, v) MZ_OPT_HASH_KEY(&((Scheme_Bignum *)b)->iso) = ((v) | SCHEME_BIGINLINE(b)) 2206 # define SCHEME_INIT_BIGPOS(b, v) MZ_OPT_HASH_KEY(&((Scheme_Bignum *)b)->iso) = (v) 2207 # define SCHEME_BIGINLINE(b) (MZ_OPT_HASH_KEY(&((Scheme_Bignum *)b)->iso) & 0x2) 2208 # define SCHEME_SET_BIGINLINE(b) MZ_OPT_HASH_KEY(&((Scheme_Bignum *)b)->iso) |= (0x2 | SCHEME_BIGPOS(b)) 2209 #else 2210 # define SCHEME_BIGPOS(b) MZ_OPT_HASH_KEY(&((Scheme_Bignum *)b)->iso) 2211 # define SCHEME_SET_BIGPOS(b, v) SCHEME_BIGPOS(b) = v 2212 # define SCHEME_INIT_BIGPOS(b, v) SCHEME_SET_BIGPOS(b, v) 2213 #endif 2214 2215 #define SCHEME_BIGLEN(b) (((Scheme_Bignum *)b)->len) 2216 #define SCHEME_BIGDIG(b) (((Scheme_Bignum *)b)->digits) 2217 2218 typedef struct { 2219 Scheme_Bignum o; 2220 bigdig v[1]; 2221 } Small_Bignum; 2222 2223 XFORM_NONGCING Scheme_Object *scheme_make_small_bignum(intptr_t v, Small_Bignum *s); 2224 char *scheme_number_to_string(int radix, Scheme_Object *obj); 2225 char *scheme_double_to_string (double d, char* s, int slen, int was_single, int *used_buffer); 2226 #ifdef MZ_LONG_DOUBLE 2227 char *scheme_long_double_to_string (long_double d, char* s, int slen, int *used_buffer); 2228 #endif 2229 2230 Scheme_Object *scheme_bignum_copy(const Scheme_Object *n); 2231 2232 XFORM_NONGCING int scheme_bignum_get_int_val(const Scheme_Object *o, intptr_t *v); 2233 XFORM_NONGCING int scheme_bignum_get_unsigned_int_val(const Scheme_Object *o, uintptr_t *v); 2234 XFORM_NONGCING int scheme_bignum_get_long_long_val(const Scheme_Object *o, mzlonglong *v); 2235 XFORM_NONGCING int scheme_bignum_get_unsigned_long_long_val(const Scheme_Object *o, umzlonglong *v); 2236 2237 XFORM_NONGCING int scheme_bignum_eq(const Scheme_Object *a, const Scheme_Object *b); 2238 XFORM_NONGCING int scheme_bignum_lt(const Scheme_Object *a, const Scheme_Object *b); 2239 XFORM_NONGCING int scheme_bignum_gt(const Scheme_Object *a, const Scheme_Object *b); 2240 XFORM_NONGCING int scheme_bignum_le(const Scheme_Object *a, const Scheme_Object *b); 2241 XFORM_NONGCING int scheme_bignum_ge(const Scheme_Object *a, const Scheme_Object *b); 2242 Scheme_Object *scheme_bignum_negate(const Scheme_Object *n); 2243 Scheme_Object *scheme_bignum_add(const Scheme_Object *a, const Scheme_Object *b); 2244 Scheme_Object *scheme_bignum_subtract(const Scheme_Object *a, const Scheme_Object *b); 2245 Scheme_Object *scheme_bignum_add1(const Scheme_Object *n); 2246 Scheme_Object *scheme_bignum_sub1(const Scheme_Object *n); 2247 Scheme_Object *scheme_bignum_multiply(const Scheme_Object *a, const Scheme_Object *b); 2248 Scheme_Object *scheme_bignum_max(const Scheme_Object *a, const Scheme_Object *b); 2249 Scheme_Object *scheme_bignum_min(const Scheme_Object *a, const Scheme_Object *b); 2250 void scheme_bignum_divide(const Scheme_Object *n, const Scheme_Object *d, 2251 Scheme_Object **qp, Scheme_Object **rp, int norm); 2252 Scheme_Object *scheme_generic_integer_power(const Scheme_Object *a, const Scheme_Object *b); 2253 Scheme_Object *scheme_bignum_gcd(const Scheme_Object *a, const Scheme_Object *b); 2254 Scheme_Object *scheme_integer_sqrt(const Scheme_Object *n); 2255 Scheme_Object *scheme_integer_sqrt_rem(const Scheme_Object *n, Scheme_Object **r); 2256 Scheme_Object *scheme_bignum_and(const Scheme_Object *a, const Scheme_Object *b); 2257 Scheme_Object *scheme_bignum_or(const Scheme_Object *a, const Scheme_Object *b); 2258 Scheme_Object *scheme_bignum_xor(const Scheme_Object *a, const Scheme_Object *b); 2259 Scheme_Object *scheme_bignum_not(const Scheme_Object *a); 2260 Scheme_Object *scheme_bignum_shift(const Scheme_Object *a, intptr_t shift); 2261 2262 XFORM_NONGCING double scheme_bignum_to_double_inf_info(const Scheme_Object *n, intptr_t just_use, intptr_t *only_need); 2263 #ifdef MZ_LONG_DOUBLE 2264 XFORM_NONGCING long_double scheme_bignum_to_long_double_inf_info(const Scheme_Object *n, intptr_t just_use, intptr_t *only_need); 2265 #endif 2266 #ifdef MZ_USE_SINGLE_FLOATS 2267 XFORM_NONGCING float scheme_bignum_to_float_inf_info(const Scheme_Object *n, intptr_t just_use, intptr_t *only_need); 2268 #else 2269 # define scheme_bignum_to_float_inf_info scheme_bignum_to_double_inf_info 2270 #endif 2271 2272 void scheme_clear_bignum_cache(void); 2273 2274 intptr_t scheme_integer_length(Scheme_Object *n); 2275 2276 char *scheme_push_c_numeric_locale(); 2277 void scheme_pop_c_numeric_locale(char *prev); 2278 2279 /****** Rational numbers *******/ 2280 2281 typedef struct { 2282 Scheme_Object so; 2283 Scheme_Object *num; 2284 Scheme_Object *denom; 2285 } Scheme_Rational; 2286 2287 typedef Scheme_Rational Small_Rational; 2288 2289 XFORM_NONGCING Scheme_Object *scheme_make_small_rational(intptr_t n, Small_Rational *space); 2290 XFORM_NONGCING Scheme_Object *scheme_make_small_bn_rational(Scheme_Object *n, Small_Rational *space); 2291 Scheme_Object *scheme_make_rational_pre_normalized(const Scheme_Object *n, const Scheme_Object *d); 2292 Scheme_Object *scheme_integer_to_rational(const Scheme_Object *n); 2293 Scheme_Object *scheme_make_fixnum_rational(intptr_t n, intptr_t d); 2294 XFORM_NONGCING int scheme_rational_eq(const Scheme_Object *a, const Scheme_Object *b); 2295 int scheme_rational_lt(const Scheme_Object *a, const Scheme_Object *b); 2296 int scheme_rational_gt(const Scheme_Object *a, const Scheme_Object *b); 2297 int scheme_rational_le(const Scheme_Object *a, const Scheme_Object *b); 2298 int scheme_rational_ge(const Scheme_Object *a, const Scheme_Object *b); 2299 Scheme_Object *scheme_rational_negate(const Scheme_Object *n); 2300 Scheme_Object *scheme_rational_add(const Scheme_Object *a, const Scheme_Object *b); 2301 Scheme_Object *scheme_rational_subtract(const Scheme_Object *a, const Scheme_Object *b); 2302 Scheme_Object *scheme_rational_add1(const Scheme_Object *n); 2303 Scheme_Object *scheme_rational_sub1(const Scheme_Object *n); 2304 Scheme_Object *scheme_rational_multiply(const Scheme_Object *a, const Scheme_Object *b); 2305 Scheme_Object *scheme_rational_max(const Scheme_Object *a, const Scheme_Object *b); 2306 Scheme_Object *scheme_rational_min(const Scheme_Object *a, const Scheme_Object *b); 2307 Scheme_Object *scheme_rational_divide(const Scheme_Object *n, const Scheme_Object *d); 2308 Scheme_Object *scheme_rational_power(const Scheme_Object *a, const Scheme_Object *b); 2309 XFORM_NONGCING int scheme_is_rational_positive(const Scheme_Object *o); 2310 Scheme_Object *scheme_rational_floor(const Scheme_Object *a); 2311 Scheme_Object *scheme_rational_truncate(const Scheme_Object *a); 2312 Scheme_Object *scheme_rational_ceiling(const Scheme_Object *a); 2313 Scheme_Object *scheme_rational_round(const Scheme_Object *a); 2314 Scheme_Object *scheme_rational_sqrt(const Scheme_Object *n); 2315 2316 /****** Complex numbers *******/ 2317 2318 typedef struct { 2319 Scheme_Object so; 2320 Scheme_Object *r; 2321 Scheme_Object *i; 2322 } Scheme_Complex; 2323 2324 typedef Scheme_Complex Small_Complex; 2325 2326 #define _scheme_complex_real_part(n) (((Scheme_Complex *)(n))->r) 2327 #define _scheme_complex_imaginary_part(n) (((Scheme_Complex *)(n))->i) 2328 2329 Scheme_Object *scheme_make_small_complex(const Scheme_Object *n, Small_Complex *space); 2330 Scheme_Object *scheme_real_to_complex(const Scheme_Object *n); 2331 int scheme_complex_eq(const Scheme_Object *a, const Scheme_Object *b); 2332 Scheme_Object *scheme_complex_negate(const Scheme_Object *n); 2333 Scheme_Object *scheme_complex_add(const Scheme_Object *a, const Scheme_Object *b); 2334 Scheme_Object *scheme_complex_subtract(const Scheme_Object *a, const Scheme_Object *b); 2335 Scheme_Object *scheme_complex_add1(const Scheme_Object *n); 2336 Scheme_Object *scheme_complex_sub1(const Scheme_Object *n); 2337 Scheme_Object *scheme_complex_multiply(const Scheme_Object *a, const Scheme_Object *b); 2338 Scheme_Object *scheme_complex_divide(const Scheme_Object *n, const Scheme_Object *d); 2339 Scheme_Object *scheme_complex_power(const Scheme_Object *a, const Scheme_Object *b); 2340 Scheme_Object *scheme_complex_sqrt(const Scheme_Object *a); 2341 Scheme_Object *scheme_complex_atan(const Scheme_Object *c); 2342 Scheme_Object *scheme_complex_asin(const Scheme_Object *c); 2343 Scheme_Object *scheme_complex_acos(const Scheme_Object *c); 2344 XFORM_NONGCING int scheme_is_complex_exact(const Scheme_Object *o); 2345 2346 /****** Inexacts ******/ 2347 2348 #define REAL_NUMBER_STR "real number" 2349 2350 int scheme_check_double(const char *where, double v, const char *dest); 2351 #ifdef MZ_LONG_DOUBLE 2352 int scheme_check_long_double(const char *where, long_double v, const char *dest); 2353 #endif 2354 #ifdef MZ_USE_SINGLE_FLOATS 2355 int scheme_check_float(const char *where, float v, const char *dest); 2356 #else 2357 # define scheme_check_float scheme_check_double 2358 #endif 2359 2360 double scheme_get_val_as_double(const Scheme_Object *n); 2361 XFORM_NONGCING int scheme_minus_zero_p(double d); 2362 2363 #ifdef MZ_LONG_DOUBLE 2364 long_double scheme_get_val_as_long_double(const Scheme_Object *n); 2365 XFORM_NONGCING int scheme_long_minus_zero_p(long_double d); 2366 #else 2367 # define scheme_long_minus_zero_p(d) scheme_minus_zero_p(d) 2368 #endif 2369 2370 #ifdef MZ_USE_SINGLE_FLOATS 2371 float scheme_get_val_as_float(const Scheme_Object *n); 2372 #endif 2373 2374 #if !defined(USE_IEEE_FP_PREDS) && !defined(USE_SCO_IEEE_PREDS) \ 2375 && !defined(USE_OSF_FP_PREDS) && !defined(USE_PALM_INF_TESTS) \ 2376 && !defined(USE_MSVC_FP_PREDS) 2377 # define MZ_IS_POS_INFINITY(d) ((d) == scheme_infinity_val) 2378 # define MZ_IS_NEG_INFINITY(d) ((d) == scheme_minus_infinity_val) 2379 # ifdef NAN_EQUALS_ANYTHING 2380 # define MZ_IS_NAN(d) (((d) == 1.0) && ((d) == 2.0)) 2381 # else 2382 # ifdef DEFEAT_FP_COMP_OPTIMIZATION 2383 extern int scheme_both_nan(double a, double b); 2384 # define MZ_IS_NAN(d) (scheme_both_nan(d, d)) 2385 # else 2386 # define MZ_IS_NAN(d) (!((d) == (d))) 2387 # endif 2388 # endif 2389 #else 2390 # ifdef USE_SCO_IEEE_PREDS 2391 # include <ieeefp.h> 2392 # define MZ_IS_POS_INFINITY(d) (fpclass(d) == FP_PINF) 2393 # define MZ_IS_NEG_INFINITY(d) (fpclass(d) == FP_NINF) 2394 # define MZ_IS_NAN(d) isnan(d) 2395 # else 2396 # ifdef USE_PALM_INF_TESTS 2397 # define MZ_IS_POS_INFINITY(d) scheme_is_pos_inf(d) 2398 # define MZ_IS_NEG_INFINITY(d) scheme_is_neg_inf(d) 2399 # define MZ_IS_NAN(d) scheme_is_nan(d) 2400 extern int scheme_is_pos_inf(double); 2401 extern int scheme_is_neg_inf(double); 2402 extern int scheme_is_nan(double); 2403 # else 2404 # ifdef USE_OSF_FP_PREDS 2405 # include <math.h> 2406 # include <fp_class.h> 2407 # define MZ_IS_POS_INFINITY(d) (fp_class(d) == FP_POS_INF) 2408 # define MZ_IS_NEG_INFINITY(d) (fp_class(d) == FP_NEG_INF) 2409 # define MZ_IS_NAN(d) isnan(d) 2410 # else 2411 # ifdef USE_CARBON_FP_PREDS 2412 # define MZ_IS_INFINITY(d) (!__isfinite(d)) 2413 # define MZ_IS_POS_INFINITY(d) (!__isfinite(d) && (d > 0)) 2414 # define MZ_IS_NEG_INFINITY(d) (!__isfinite(d) && (d < 0)) 2415 # define MZ_IS_NAN(d) __isnan(d) 2416 # define MZ_IS_NEG_ZERO(d) signbit(d) 2417 # else 2418 # ifdef USE_MSVC_FP_PREDS 2419 # include <float.h> 2420 # define MZ_IS_POS_INFINITY(d) (_fpclass(d) == _FPCLASS_PINF) 2421 # define MZ_IS_NEG_INFINITY(d) (_fpclass(d) == _FPCLASS_NINF) 2422 # define MZ_IS_NAN(d) _isnan(d) 2423 # else 2424 /* USE_IEEE_FP_PREDS */ 2425 # include <math.h> 2426 # define MZ_IS_INFINITY(d) (isinf(d)) 2427 # define MZ_IS_POS_INFINITY(d) (isinf(d) && (d > 0)) 2428 # define MZ_IS_NEG_INFINITY(d) (isinf(d) && (d < 0)) 2429 # define MZ_IS_NAN(d) isnan(d) 2430 # define MZ_IS_NEG_ZERO(d) signbit(d) 2431 # endif 2432 # endif 2433 # endif 2434 # endif 2435 # endif 2436 #endif 2437 2438 #ifdef MZ_LONG_DOUBLE_API_IS_EXTERNAL 2439 # define MZ_IS_LONG_INFINITY(d) long_double_is_infinity(d) 2440 # define MZ_IS_LONG_POS_INFINITY(d) long_double_is_pos_infinity(d) 2441 # define MZ_IS_LONG_NEG_INFINITY(d) long_double_is_neg_infinity(d) 2442 # define MZ_IS_LONG_NAN(d) long_double_is_nan(d) 2443 #else 2444 # define MZ_IS_LONG_INFINITY(d) MZ_IS_INFINITY(d) 2445 # define MZ_IS_LONG_POS_INFINITY(d) MZ_IS_POS_INFINITY(d) 2446 # define MZ_IS_LONG_NEG_INFINITY(d) MZ_IS_NEG_INFINITY(d) 2447 # define MZ_IS_LONG_NAN(d) MZ_IS_NAN(d) 2448 #endif 2449 2450 #ifndef MZ_IS_INFINITY 2451 # define MZ_IS_INFINITY(d) (MZ_IS_POS_INFINITY(d) || MZ_IS_NEG_INFINITY(d)) 2452 #endif 2453 2454 #define IZI_REAL_PART(n) (((Scheme_Complex *)(n))->r) 2455 2456 extern double scheme_infinity_val, scheme_minus_infinity_val; 2457 extern double scheme_floating_point_zero; 2458 extern double scheme_floating_point_nzero; 2459 extern Scheme_Object *scheme_zerod, *scheme_nzerod, *scheme_pi, *scheme_half_pi, *scheme_minus_half_pi; 2460 extern Scheme_Object *scheme_plus_i, *scheme_minus_i; 2461 extern Scheme_Object *scheme_inf_object, *scheme_minus_inf_object, *scheme_nan_object; 2462 #ifdef MZ_LONG_DOUBLE 2463 extern long_double scheme_long_infinity_val, scheme_long_minus_infinity_val; 2464 extern long_double scheme_long_floating_point_zero; 2465 extern long_double scheme_long_floating_point_nzero; 2466 extern Scheme_Object *scheme_zerol, *scheme_nzerol, *scheme_long_scheme_pi; 2467 extern Scheme_Object *scheme_long_inf_object, *scheme_long_minus_inf_object, *scheme_long_nan_object; 2468 #endif 2469 #ifdef MZ_USE_SINGLE_FLOATS 2470 extern Scheme_Object *scheme_zerof, *scheme_nzerof, *scheme_single_scheme_pi; 2471 extern Scheme_Object *scheme_single_inf_object, *scheme_single_minus_inf_object, *scheme_single_nan_object; 2472 #endif 2473 2474 XFORM_NONGCING double scheme_double_random(Scheme_Object *rand_state); 2475 2476 /****** General numeric ******/ 2477 2478 Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, 2479 int is_float, 2480 int is_not_float, 2481 int decimal_means_float, 2482 int radix, int radix_set, 2483 Scheme_Object *port, 2484 int *div_by_zero, 2485 int test_only); 2486 2487 Scheme_Object *scheme_bin_gcd(const Scheme_Object *n1, const Scheme_Object *n2); 2488 Scheme_Object *scheme_bin_quotient(const Scheme_Object *n1, const Scheme_Object *n2); 2489 Scheme_Object *scheme_bin_mult(const Scheme_Object *n1, const Scheme_Object *n2); 2490 Scheme_Object *scheme_bin_div(const Scheme_Object *n1, const Scheme_Object *n2); 2491 Scheme_Object *scheme_bin_plus(const Scheme_Object *n1, const Scheme_Object *n2); 2492 Scheme_Object *scheme_bin_minus(const Scheme_Object *n1, const Scheme_Object *n2); 2493 int scheme_bin_eq(const Scheme_Object *n1, const Scheme_Object *n2); 2494 int scheme_bin_lt(const Scheme_Object *n1, const Scheme_Object *n2); 2495 int scheme_bin_gt(const Scheme_Object *n1, const Scheme_Object *n2); 2496 int scheme_bin_gt_eq(const Scheme_Object *n1, const Scheme_Object *n2); 2497 int scheme_bin_lt_eq(const Scheme_Object *n1, const Scheme_Object *n2); 2498 2499 Scheme_Object *scheme_bin_quotient_remainder(const Scheme_Object *n1, const Scheme_Object *n2, Scheme_Object **_rem); 2500 2501 Scheme_Object *scheme_bin_bitwise_or(Scheme_Object *a, Scheme_Object *b); 2502 Scheme_Object *scheme_bin_bitwise_xor(Scheme_Object *a, Scheme_Object *b); 2503 Scheme_Object *scheme_bin_bitwise_and(Scheme_Object *a, Scheme_Object *b); 2504 int scheme_bin_bitwise_bit_set_p (Scheme_Object *so, Scheme_Object *sb); 2505 2506 Scheme_Object *scheme_sub1(int argc, Scheme_Object *argv[]); 2507 Scheme_Object *scheme_add1(int argc, Scheme_Object *argv[]); 2508 Scheme_Object *scheme_odd_p(int argc, Scheme_Object *argv[]); 2509 Scheme_Object *scheme_even_p(int argc, Scheme_Object *argv[]); 2510 Scheme_Object *scheme_expt(int argc, Scheme_Object *argv[]); 2511 Scheme_Object *scheme_modulo(int argc, Scheme_Object *argv[]); 2512 Scheme_Object *scheme_sqrt(int argc, Scheme_Object *argv[]); 2513 Scheme_Object *scheme_abs(int argc, Scheme_Object *argv[]); 2514 2515 Scheme_Object *scheme_inexact_to_exact(int argc, Scheme_Object *argv[]); 2516 Scheme_Object *scheme_exact_to_inexact(int argc, Scheme_Object *argv[]); 2517 Scheme_Object *scheme_inexact_p(int argc, Scheme_Object *argv[]); 2518 Scheme_Object *scheme_TO_DOUBLE(const Scheme_Object *n); 2519 #ifdef MZ_LONG_DOUBLE 2520 Scheme_Object *scheme_TO_LONG_DOUBLE(const Scheme_Object *n); 2521 #endif 2522 Scheme_Object *scheme_to_bignum(const Scheme_Object *o); 2523 XFORM_NONGCING int scheme_is_integer(const Scheme_Object *o); 2524 XFORM_NONGCING int scheme_is_zero(const Scheme_Object *o); 2525 XFORM_NONGCING int scheme_is_negative(const Scheme_Object *o); 2526 XFORM_NONGCING int scheme_is_positive(const Scheme_Object *o); 2527 Scheme_Object *scheme_make_polar(int argc, Scheme_Object *argv[]); 2528 2529 Scheme_Object *scheme_bitwise_shift(int argc, Scheme_Object *argv[]); 2530 Scheme_Object *scheme_bitwise_and(int argc, Scheme_Object *argv[]); 2531 2532 int scheme_exact_p(Scheme_Object *n); 2533 int scheme_nonneg_exact_p(Scheme_Object *n); 2534 2535 Scheme_Object *scheme_floor(int argc, Scheme_Object *argv[]); 2536 2537 Scheme_Object *scheme_bytes_to_integer(char *str, int slen, int sgned, int rshft, int mask); 2538 2539 #define scheme_make_integer_value_from_time(t) scheme_make_integer_value((intptr_t)t) 2540 #define scheme_get_time_val(o, v) scheme_get_int_val(o, v) 2541 #define UNBUNDLE_TIME_TYPE intptr_t 2542 2543 /***** Random number generator *****/ 2544 2545 #ifdef MZ_BSD_RANDOM_GENERATOR 2546 # define MZ_RANDOM_STATE_DEG 31 2547 typedef struct { 2548 Scheme_Object so; 2549 short fpos, rpos; 2550 long state[MZ_RANDOM_STATE_DEG]; 2551 } Scheme_Random_State; 2552 #else 2553 typedef struct { 2554 Scheme_Object so; 2555 double x10, x11, x12, x20, x21, x22; 2556 } Scheme_Random_State; 2557 #endif 2558 2559 Scheme_Object *scheme_make_random_state(intptr_t seed); 2560 intptr_t scheme_rand(Scheme_Random_State *rs); 2561 2562 /***** flonums *****/ 2563 2564 XFORM_NONGCING double scheme_double_truncate(double x); 2565 XFORM_NONGCING double scheme_double_round(double x); 2566 XFORM_NONGCING double scheme_double_floor(double x); 2567 XFORM_NONGCING double scheme_double_ceiling(double x); 2568 XFORM_NONGCING double scheme_double_single(double x); 2569 XFORM_NONGCING double scheme_double_sin(double x); 2570 XFORM_NONGCING double scheme_double_cos(double x); 2571 XFORM_NONGCING double scheme_double_tan(double x); 2572 XFORM_NONGCING double scheme_double_asin(double x); 2573 XFORM_NONGCING double scheme_double_acos(double x); 2574 XFORM_NONGCING double scheme_double_atan(double x); 2575 XFORM_NONGCING double scheme_double_atan2(double v, double v2); 2576 XFORM_NONGCING double scheme_double_log(double x); 2577 XFORM_NONGCING double scheme_double_exp(double x); 2578 XFORM_NONGCING double scheme_double_expt(double x, double y); 2579 2580 /***** extflonums *****/ 2581 #ifdef MZ_LONG_DOUBLE 2582 long_double scheme_long_double_truncate(long_double x); 2583 long_double scheme_long_double_round(long_double x); 2584 long_double scheme_long_double_floor(long_double x); 2585 long_double scheme_long_double_ceiling(long_double x); 2586 long_double scheme_long_double_sin(long_double x); 2587 long_double scheme_long_double_cos(long_double x); 2588 long_double scheme_long_double_tan(long_double x); 2589 long_double scheme_long_double_asin(long_double x); 2590 long_double scheme_long_double_acos(long_double x); 2591 long_double scheme_long_double_atan(long_double x); 2592 long_double scheme_long_double_log(long_double x); 2593 long_double scheme_long_double_exp(long_double x); 2594 long_double scheme_long_double_expt(long_double x, long_double y); 2595 #endif 2596 /*========================================================================*/ 2597 /* read, eval, print */ 2598 /*========================================================================*/ 2599 2600 /* A "prefix" is put on the stack and captured by closures to captures 2601 a set of top-level or module variables and syntax 2602 objects. Top-level and module variables are packed together in a 2603 prefix on the theory that a lot of them may be captured in a single 2604 closure, and so it's better to keep one layer of hierarchy. For 2605 3m, special GC cooperation allows a prefix's set of variables to be 2606 pruned (i.e., dropped from the prefix) for slots that are not used 2607 by any closure, when the prefix is accessed only by closures. */ 2608 typedef struct Scheme_Prefix 2609 { 2610 Scheme_Inclhash_Object iso; /* scheme_prefix_type; 0x1 => incremental-mode fixup chain */ 2611 int num_slots, saw_num_slots; 2612 #ifdef MZ_PRECISE_GC 2613 struct Scheme_Prefix *next_final; /* for special GC handling */ 2614 struct Scheme_Object *fixup_chain; /* for special GC handling */ 2615 #endif 2616 #ifdef MZ_GC_BACKTRACE 2617 Scheme_Object *backpointer; 2618 #endif 2619 Scheme_Object *a[mzFLEX_ARRAY_DECL]; /* array of objects */ 2620 /* followed by an array of `int's for tl_map uses */ 2621 } Scheme_Prefix; 2622 2623 #define SCHEME_PREFIX_FLAGS(obj) MZ_OPT_HASH_KEY(&(obj)->iso) 2624 2625 #define PREFIX_TO_USE_BITS(pf) \ 2626 (int *)((char *)pf + sizeof(Scheme_Prefix) + ((pf->num_slots - mzFLEX_DELTA) * sizeof(Scheme_Object *))) 2627 2628 Scheme_Prefix *scheme_allocate_prefix(intptr_t n); 2629 Scheme_Prefix *scheme_allocate_linklet_prefix(Scheme_Linklet *linklet, int extra); 2630 2631 #define LOAD_ON_DEMAND 2632 void scheme_clear_delayed_load_cache(); 2633 2634 #define _scheme_do_eval(obj, env, v) \ 2635 ((SCHEME_INTP(obj) || !SCHEME_STRTAG_VAL(_SCHEME_TYPE(obj))) \ 2636 ? obj : scheme_do_eval(obj, -1, env, v)) 2637 #define q_scheme_eval_linked(obj) _scheme_do_eval(obj, 1) 2638 #define q_scheme_tail_eval(obj) scheme_tail_eval(obj) 2639 2640 Scheme_Object *scheme_eval_linked_expr(Scheme_Object *expr); 2641 Scheme_Object *scheme_eval_linked_expr_multi(Scheme_Object *expr); 2642 2643 Scheme_Object *_scheme_apply_to_list (Scheme_Object *rator, Scheme_Object *rands); 2644 Scheme_Object *_scheme_tail_apply_to_list (Scheme_Object *rator, Scheme_Object *rands); 2645 2646 Scheme_Object *_scheme_apply_native(Scheme_Object *obj, int num_rands, Scheme_Object **rands); 2647 2648 Scheme_Object *scheme_instantiate_linklet_multi(Scheme_Linklet *linklet, Scheme_Instance *instance, 2649 int num_instances, Scheme_Instance **instances, 2650 int use_prompt); 2651 2652 Scheme_Object *scheme_internal_read(Scheme_Object *port, int crc, int cantfail, 2653 int pre_char, 2654 Scheme_Object *delay_load_info); 2655 void scheme_internal_display(Scheme_Object *obj, Scheme_Object *port); 2656 void scheme_internal_write(Scheme_Object *obj, Scheme_Object *port); 2657 void scheme_internal_print(Scheme_Object *obj, Scheme_Object *port, Scheme_Object *quote_depth); 2658 2659 Scheme_Object *scheme_read_language(Scheme_Object *port, int nonlang_ok); 2660 2661 Scheme_Object *scheme_read_linklet_bundle_hash(Scheme_Object *port); 2662 2663 #define _scheme_eval_linked_expr(obj) scheme_do_eval(obj,-1,NULL,1) 2664 #define _scheme_eval_linked_expr_multi(obj) scheme_do_eval(obj,-1,NULL,-1) 2665 #define _scheme_eval_linked_expr_wp(obj, p) scheme_do_eval_w_thread(obj,-1,NULL,1,p) 2666 #define _scheme_eval_linked_expr_multi_wp(obj, p) scheme_do_eval_w_thread(obj,-1,NULL,-1,p) 2667 2668 Scheme_Object *scheme_named_map_1(char *, 2669 Scheme_Object *(*fun)(Scheme_Object*, Scheme_Object *form), 2670 Scheme_Object *lst, Scheme_Object *form); 2671 2672 XFORM_NONGCING int scheme_strncmp(const char *a, const char *b, int len); 2673 2674 #define _scheme_make_char(ch) scheme_make_character(ch) 2675 2676 Scheme_Object *scheme_default_print_handler(int, Scheme_Object *[]); 2677 Scheme_Object *scheme_default_prompt_read_handler(int, Scheme_Object *[]); 2678 Scheme_Object *scheme_default_read_input_port_handler(int argc, Scheme_Object *[]); 2679 Scheme_Object *scheme_default_read_handler(int argc, Scheme_Object *[]); 2680 2681 extern Scheme_Object *scheme_eof_object_p_proc; 2682 extern Scheme_Object *scheme_default_global_print_handler; 2683 2684 Scheme_Object *scheme_make_default_readtable(void); 2685 Scheme_Object *scheme_read_intern(Scheme_Object *o); 2686 2687 Scheme_Object *_scheme_apply_from_native(Scheme_Object *rator, 2688 int argc, 2689 Scheme_Object **argv); 2690 Scheme_Object *_scheme_apply_multi_from_native(Scheme_Object *rator, 2691 int argc, 2692 Scheme_Object **argv); 2693 Scheme_Object *_scheme_tail_apply_from_native(Scheme_Object *rator, 2694 int argc, 2695 Scheme_Object **argv); 2696 2697 Scheme_Object *scheme_force_value_same_mark(Scheme_Object *); 2698 Scheme_Object *scheme_force_one_value_same_mark(Scheme_Object *); 2699 2700 void scheme_flush_stack_cache(void); 2701 2702 struct Scheme_Load_Delay; 2703 Scheme_Object *scheme_load_delayed_code(int pos, struct Scheme_Load_Delay *ld); 2704 2705 intptr_t scheme_get_print_width(void); 2706 2707 #include "../utils/schiptr.h" 2708 2709 /*========================================================================*/ 2710 /* compile and link */ 2711 /*========================================================================*/ 2712 2713 typedef struct Scheme_Comp_Env 2714 { 2715 MZTAG_IF_REQUIRED 2716 int flags; 2717 Scheme_Hash_Tree *vars; /* symbol -> Scheme_IR_Local */ 2718 Scheme_Object *value_name; /* propagated down */ 2719 Scheme_Linklet *linklet; 2720 } Scheme_Comp_Env; 2721 2722 #define COMP_ENV_CHECKING_CONSTANT 0x1 2723 #define COMP_ENV_DONT_COUNT_AS_USE 0x2 2724 #define COMP_ENV_ALLOW_SET_UNDEFINED 0x4 2725 2726 Scheme_Comp_Env *scheme_new_comp_env(Scheme_Linklet *linklet, int flags); 2727 Scheme_Comp_Env *scheme_extend_comp_env(Scheme_Comp_Env *env, Scheme_Object *id, Scheme_Object *var, 2728 int mutate, int check_dups); 2729 Scheme_Comp_Env *scheme_set_comp_env_flags(Scheme_Comp_Env *env, int flags); 2730 Scheme_Comp_Env *scheme_set_comp_env_name(Scheme_Comp_Env *env, Scheme_Object *name); 2731 2732 #define LAMBDA_HAS_REST 1 2733 #define LAMBDA_HAS_TYPED_ARGS 2 2734 #define LAMBDA_PRESERVES_MARKS 4 2735 #define LAMBDA_NEED_REST_CLEAR 8 2736 #define LAMBDA_IS_METHOD 16 2737 #define LAMBDA_SINGLE_RESULT 32 2738 #define LAMBDA_STATUS_MASK (64 | 128) 2739 #define LAMBDA_SFS 256 2740 /* BITS 8-15 (overlaps LAMBDA_SFS) used by write_lambda() */ 2741 2742 /* These modes correspond to different times for a given `lambda`, 2743 assuming that builtin functions are not validated: */ 2744 #define LAMBDA_STATUS_RESULT_TENTATIVE 64 2745 #define LAMBDA_STATUS_VALIDATED 128 2746 #define LAMBDA_STATUS_BUILTIN (128 | 64) 2747 2748 #define COMP_ALLOW_SET_UNDEFINED 0x1 2749 #define COMP_CAN_INLINE 0x2 2750 #define COMP_ENFORCE_CONSTS 0x4 2751 #define COMP_TESTING_CONSTANTNESS 0x8 2752 #define RESOLVE_MODULE_IDS 0x10 2753 2754 typedef struct Resolve_Info Resolve_Info; 2755 2756 /* Scheme_IR_Lambda_Info is used to store extra closure information 2757 before a closure mapping is resolved. */ 2758 typedef struct { 2759 MZTAG_IF_REQUIRED 2760 Scheme_Hash_Table *base_closure; 2761 Scheme_IR_Local **vars; 2762 Scheme_Object **arg_types; /* predicates for the arguments, as determined by callers */ 2763 short *arg_type_contributors; /* bitmap of applications that have provided type info; 2764 when the number of calls is know, this information 2765 can reveal when all callers have checked in; the 2766 contributor SCHEME_USE_COUNT_INF is an anonymous 2767 contributor; if a contributor set is non-empty; 2768 then NULL for a type mean "top" */ 2769 char has_tl, has_nonleaf, is_dup; 2770 int body_size, body_psize; 2771 } Scheme_IR_Lambda_Info; 2772 2773 typedef struct Optimize_Info Optimize_Info; 2774 2775 typedef struct CPort Mz_CPort; 2776 2777 typedef struct Scheme_Lambda 2778 { 2779 Scheme_Inclhash_Object iso; /* keyex used for flags */ 2780 mzshort num_params; /* includes collecting arg if has_rest */ 2781 mzshort max_let_depth; 2782 mzshort closure_size; /* the number of closed-over variables */ 2783 union { 2784 Scheme_IR_Lambda_Info *ir_info; /* used until resolve pass */ 2785 mzshort *closure_map; /* after resolve pass: 2786 contains closure_size elements mapping closed-over var to stack positions. 2787 2788 If LAMBDA_HAS_TYPED_ARGS, that array is followed by bit array with 2789 LAMBDA_TYPE_BITS_PER_ARG bits per args then per closed-over 2790 2791 total size = closure_size + (closure_size + num_params) * LAMBDA_TYPE_BITS_PER_ARG */ 2792 }; 2793 Scheme_Object *body; 2794 Scheme_Object *name; /* name or (vector name src line col pos span generated?) */ 2795 void *tl_map; /* fixnum or bit array (as array of `int's) indicating which globals+lifts in prefix are used */ 2796 #ifdef MZ_USE_JIT 2797 union { 2798 struct Scheme_Lambda *jit_clone; 2799 struct Scheme_Native_Lambda *native_code; /* generated by lightning */ 2800 } u; 2801 Scheme_Object *context; /* e.g., a letrec that binds the closure */ 2802 #endif 2803 } Scheme_Lambda; 2804 2805 #define SCHEME_LAMBDA_FLAGS(obj) MZ_OPT_HASH_KEY(&(obj)->iso) 2806 2807 #define LAMBDA_TYPE_BITS_PER_ARG 4 2808 #define LAMBDA_TYPE_BOXED 1 2809 #define LAMBDA_TYPE_TYPE_OFFSET 1 2810 2811 XFORM_NONGCING void scheme_boxmap_set(mzshort *boxmap, int j, int bit, int delta); 2812 XFORM_NONGCING int scheme_boxmap_get(mzshort *boxmap, int j, int delta); 2813 XFORM_NONGCING int scheme_boxmap_size(int n); 2814 2815 int scheme_has_method_property(Scheme_Object *code); 2816 2817 typedef struct Scheme_Closure { 2818 Scheme_Object so; 2819 Scheme_Lambda *code; 2820 Scheme_Object *vals[mzFLEX_ARRAY_DECL]; 2821 } Scheme_Closure; 2822 2823 #define SCHEME_CLOSURE_CODE(c) ((Scheme_Closure *)c)->code 2824 #define SCHEME_CLOSURE_ENV(c) ((Scheme_Closure *)c)->vals 2825 2826 #define ZERO_SIZED_CLOSUREP(closure) !(closure->code->closure_size) 2827 2828 typedef struct Scheme_Native_Lambda { 2829 Scheme_Inclhash_Object iso; /* type tag only set when needed, but 2830 flags always needed */ 2831 Scheme_Native_Proc *start_code; /* When not yet JITted, this is = to 2832 scheme_on_demand_jit_code */ 2833 union { 2834 void *tail_code; /* For non-case-lambda */ 2835 mzshort *arities; /* For case-lambda */ 2836 } u; 2837 void *arity_code; 2838 mzshort max_let_depth; /* In bytes instead of words */ 2839 mzshort closure_size; /* If this is negative, then this is a 2840 case-lambda, and the number of cases is 2841 (-closure-size)-1 */ 2842 union { 2843 struct Scheme_Lambda *orig_code; /* For not-yet-JITted 2844 non-case-lambda */ 2845 Scheme_Object *name; 2846 } u2; 2847 void *tl_map; 2848 #ifdef MZ_PRECISE_GC 2849 void **retained; /* inside code */ 2850 #endif 2851 #if defined(MZ_USE_JIT_ARM) && !defined(MZ_PRECISE_GC) 2852 # define NEED_RETAIN_CODE_POINTERS 2853 /* Thumb code is off by one, need real start for GC */ 2854 void *retain_code; 2855 #endif 2856 void *eq_key; /* for `procedure-closure-contents-eq?` */ 2857 } Scheme_Native_Lambda; 2858 2859 #define SCHEME_NATIVE_LAMBDA_FLAGS(obj) MZ_OPT_HASH_KEY(&(obj)->iso) 2860 2861 /* This flag is set pre-JIT: */ 2862 #define NATIVE_SPECIALIZED 0x1 2863 /* Other flags are in "jit.h" */ 2864 2865 typedef struct { 2866 Scheme_Object so; 2867 Scheme_Native_Lambda *code; 2868 Scheme_Object *vals[mzFLEX_ARRAY_DECL]; 2869 } Scheme_Native_Closure; 2870 2871 Scheme_Native_Lambda *scheme_generate_lambda(Scheme_Lambda *obj, int drop_code, 2872 Scheme_Native_Lambda *case_lam); 2873 2874 typedef struct Scheme_Current_LWC { 2875 /* !! All of these fields are treated as atomic by the GC !! */ 2876 Scheme_Object **runstack_start; 2877 MZ_MARK_STACK_TYPE cont_mark_stack_start; 2878 MZ_MARK_POS_TYPE cont_mark_pos_start; 2879 void *stack_start; 2880 Scheme_Object **runstack_end; 2881 Scheme_Object **runstack_base_end; 2882 MZ_MARK_STACK_TYPE cont_mark_stack_end; 2883 MZ_MARK_POS_TYPE cont_mark_pos_end; 2884 void *frame_end; 2885 void *stack_end; 2886 void *original_dest; 2887 void *saved_v1; 2888 double saved_save_fp; 2889 #ifdef MZ_LONG_DOUBLE 2890 long_double saved_save_extfp; 2891 #endif 2892 } Scheme_Current_LWC; 2893 2894 void scheme_init_thread_lwc(void); 2895 void scheme_fill_lwc_start(void); 2896 void scheme_fill_lwc_end(void); 2897 void scheme_fill_stack_lwc_end(void); 2898 void scheme_clear_lwc(void); 2899 2900 THREAD_LOCAL_DECL(MZ_EXTERN Scheme_Current_LWC *scheme_current_lwc); 2901 2902 Scheme_Object *scheme_call_as_lightweight_continuation(Scheme_Native_Proc *code, 2903 void *data, 2904 int argc, 2905 Scheme_Object **argv); 2906 void *scheme_save_lightweight_continuation_stack(Scheme_Current_LWC *lwc); 2907 Scheme_Object *scheme_apply_lightweight_continuation_stack(Scheme_Current_LWC *lwc, void *stack, 2908 Scheme_Object *result); 2909 struct Scheme_Lightweight_Continuation; 2910 typedef struct Scheme_Lightweight_Continuation Scheme_Lightweight_Continuation; 2911 Scheme_Lightweight_Continuation *scheme_capture_lightweight_continuation(Scheme_Thread *p, 2912 Scheme_Current_LWC *p_lwc, 2913 void **storage); 2914 Scheme_Object *scheme_apply_lightweight_continuation(Scheme_Lightweight_Continuation *captured, 2915 Scheme_Object *result, 2916 int result_is_rs_argv, 2917 intptr_t min_stacksize); 2918 Scheme_Object **scheme_adjust_runstack_argument(Scheme_Lightweight_Continuation *captured, 2919 Scheme_Object **arg); 2920 2921 Scheme_Lightweight_Continuation *scheme_restore_lightweight_continuation_marks(Scheme_Lightweight_Continuation *lw); 2922 2923 int scheme_can_apply_lightweight_continuation(Scheme_Lightweight_Continuation *captured, 2924 int check_overflow); 2925 2926 int scheme_push_marks_from_thread(Scheme_Thread *p2, Scheme_Cont_Frame_Data *d); 2927 int scheme_push_marks_from_lightweight_continuation(Scheme_Lightweight_Continuation *captured, 2928 Scheme_Cont_Frame_Data *d); 2929 2930 Scheme_Object *scheme_make_toplevel(mzshort depth, int position, int flags); 2931 2932 #define MAX_CONST_LOCAL_POS 64 2933 #define MAX_CONST_LOCAL_TYPES 2 2934 #define MAX_CONST_LOCAL_FLAG_VAL (2 + SCHEME_MAX_LOCAL_TYPE) 2935 2936 #define MAX_CONST_TOPLEVEL_DEPTH 16 2937 #define MAX_CONST_TOPLEVEL_POS 16 2938 2939 #define ASSERT_IS_VARIABLE_BUCKET(b) /* if (((Scheme_Object *)b)->type != scheme_variable_type) abort() */ 2940 2941 Scheme_IR_Local *scheme_make_ir_local(Scheme_Object *id); 2942 2943 Scheme_Object *scheme_namespace_lookup_value(Scheme_Object *sym, Scheme_Env *genv, 2944 Scheme_Object **_id, int *_use_map); 2945 2946 2947 /* Flags used with scheme_compile_lookup */ 2948 #define SCHEME_APP_POS 2 2949 #define SCHEME_SETTING 4 2950 #define SCHEME_NULL_FOR_UNBOUND 512 2951 #define SCHEME_REFERENCING 4096 2952 2953 Scheme_Object *scheme_compile_lookup(Scheme_Object *symbol, Scheme_Comp_Env *env, int flags); 2954 int scheme_is_imported(Scheme_Object *var, Scheme_Comp_Env *env); 2955 2956 Scheme_Object *scheme_extract_unsafe(Scheme_Object *o); 2957 Scheme_Object *scheme_extract_flfxnum(Scheme_Object *o); 2958 Scheme_Object *scheme_extract_extfl(Scheme_Object *o); 2959 Scheme_Object *scheme_extract_futures(Scheme_Object *o); 2960 Scheme_Object *scheme_extract_foreign(Scheme_Object *o); 2961 2962 Scheme_Object *scheme_clone_vector(Scheme_Object *data, int skip, int set_type); 2963 2964 Scheme_Object *scheme_make_closure(Scheme_Thread *p, 2965 Scheme_Object *compiled_code, 2966 int close); 2967 Scheme_Closure *scheme_malloc_empty_closure(void); 2968 2969 Scheme_Object *scheme_make_native_closure(Scheme_Native_Lambda *code); 2970 Scheme_Object *scheme_make_native_case_closure(Scheme_Native_Lambda *code); 2971 2972 void scheme_reset_app2_eval_type(Scheme_App2_Rec *app); 2973 void scheme_reset_app3_eval_type(Scheme_App3_Rec *app); 2974 2975 Scheme_Native_Lambda *scheme_generate_case_lambda(Scheme_Case_Lambda *cl); 2976 2977 void scheme_delay_load_closure(Scheme_Lambda *data); 2978 2979 Scheme_Object *scheme_compiled_void(void); 2980 2981 void scheme_merge_undefineds(Scheme_Comp_Env *exp_env, Scheme_Comp_Env *env); 2982 2983 typedef struct SFS_Info SFS_Info; 2984 2985 Scheme_Linklet *scheme_sfs_linklet(Scheme_Linklet *linklet); 2986 2987 typedef struct Scheme_Set_Bang { 2988 Scheme_Object so; 2989 int set_undef; 2990 Scheme_Object *var, *val; 2991 } Scheme_Set_Bang; 2992 2993 Scheme_Object *scheme_protect_quote(Scheme_Object *expr); 2994 2995 Scheme_Linklet *scheme_letrec_check_linklet(Scheme_Linklet *linklet); 2996 2997 Scheme_Linklet *scheme_optimize_linklet(Scheme_Linklet *linklet, 2998 int enforce_const, int can_inline, int unsafe_mode, 2999 Scheme_Object **_import_keys, Scheme_Object *get_import); 3000 3001 /* Context uses result as a boolean: */ 3002 #define OPT_CONTEXT_BOOLEAN 0x1 3003 /* Context might duplicate the expression: */ 3004 #define OPT_CONTEXT_NO_SINGLE 0x2 3005 /* Context checks that result is a single value and is non-tail w.r.t. to same clock as bindig: */ 3006 #define OPT_CONTEXT_SINGLED 0x4 3007 #define OPT_CONTEXT_TYPE_SHIFT 4 3008 #define OPT_CONTEXT_TYPE_MASK (SCHEME_MAX_LOCAL_TYPE_MASK << OPT_CONTEXT_TYPE_SHIFT) 3009 #define OPT_CONTEXT_TYPE(oc) ((oc & OPT_CONTEXT_TYPE_MASK) >> OPT_CONTEXT_TYPE_SHIFT) 3010 #define OPT_CONTEXT_APP_COUNT_SHIFT (OPT_CONTEXT_TYPE_SHIFT + SCHEME_MAX_LOCAL_TYPE_BITS) 3011 #define OPT_CONTEXT_APP_COUNT(oc) ((oc >> OPT_CONTEXT_APP_COUNT_SHIFT) & SCHEME_USE_COUNT_INF) 3012 3013 #define scheme_optimize_result_context(c) (c & (~(OPT_CONTEXT_TYPE_MASK | OPT_CONTEXT_NO_SINGLE | OPT_CONTEXT_SINGLED))) 3014 #define scheme_optimize_tail_context(c) scheme_optimize_result_context(c) 3015 3016 int scheme_ir_duplicate_ok(Scheme_Object *o, int cross_mod); 3017 int scheme_is_statically_proc(Scheme_Object *value, Optimize_Info *info, int flags); 3018 XFORM_NONGCING int scheme_predicate_to_local_type(Scheme_Object *pred); 3019 Scheme_Object *scheme_make_noninline_proc(Scheme_Object *e); 3020 Scheme_Object *scheme_optimize_extract_tail_inside(Scheme_Object *t2); 3021 3022 Scheme_Linklet *scheme_resolve_linklet(Scheme_Linklet *, int enforce_const, int static_mode); 3023 Scheme_Object *scheme_unresolve(Scheme_Object *, int argv, int *_has_cases, 3024 Scheme_Linklet *linklet, Scheme_Object *linklet_key, 3025 Optimize_Info *opt_info); 3026 Scheme_Linklet *scheme_unresolve_linklet(Scheme_Linklet *, int comp_flags); 3027 3028 /* Callbacks from unresolver to optimizer: */ 3029 Scheme_Object *scheme_optimize_add_import_variable(Optimize_Info *info, Scheme_Object *linklet_key, Scheme_Object *symbol); 3030 Scheme_Object *scheme_optimize_get_import_key(Optimize_Info *info, Scheme_Object *linklet_key, int instance_pos); 3031 3032 int scheme_check_leaf_rator(Scheme_Object *le); 3033 3034 int scheme_is_ir_lambda(Scheme_Object *o, int can_be_closed, int can_be_liftable); 3035 3036 Scheme_Object *scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info); 3037 3038 char *scheme_optimize_info_context(Optimize_Info *); 3039 Scheme_Logger *scheme_optimize_info_logger(Optimize_Info *); 3040 3041 Scheme_Object *scheme_toplevel_to_flagged_toplevel(Scheme_Object *tl, int flags); 3042 3043 int scheme_expr_produces_local_type(Scheme_Object *expr, int *_involves_k_cross); 3044 3045 Scheme_Linklet *scheme_compile_and_optimize_linklet(Scheme_Object *form, Scheme_Object *name); 3046 Scheme_Linklet *scheme_compile_linklet(Scheme_Object *form, int set_undef, Scheme_Object *import_keys); 3047 3048 Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *compiled_list, 3049 int strip_values, 3050 int resolved); 3051 3052 Scheme_App_Rec *scheme_malloc_application(int n); 3053 void scheme_finish_application(Scheme_App_Rec *app); 3054 3055 Scheme_Sequence *scheme_malloc_sequence(int count); 3056 3057 Scheme_Linklet *scheme_jit_linklet(Scheme_Linklet *, int step); 3058 Scheme_Object *scheme_jit_closure(Scheme_Object *, Scheme_Object *context); 3059 void scheme_jit_fill_threadlocal_table(); 3060 3061 #ifdef MZ_USE_JIT 3062 void scheme_on_demand_generate_lambda(Scheme_Native_Closure *nc, int argc, Scheme_Object **argv, int delta); 3063 void scheme_force_jit_generate(Scheme_Native_Lambda *nlam); 3064 #endif 3065 3066 struct Start_Module_Args; 3067 3068 #ifdef MZ_USE_JIT 3069 Scheme_Object *scheme_linklet_run_start(Scheme_Linklet* linklet, Scheme_Instance *instance, Scheme_Object *name); 3070 #endif 3071 Scheme_Object *scheme_linklet_run_finish(Scheme_Linklet* linklet, Scheme_Instance *instance, int use_prompt); 3072 3073 Scheme_Object *scheme_build_closure_name(Scheme_Object *code, Scheme_Comp_Env *env); 3074 3075 /* flags reported by scheme_resolve_info_flags */ 3076 #define SCHEME_INFO_BOXED 0x1 3077 #define SCHEME_INFO_TYPED_VAL_SHIFT 4 3078 #define SCHEME_INFO_TYPED_VAL_MASK (SCHEME_MAX_LOCAL_TYPE_MASK << SCHEME_INFO_TYPED_VAL_SHIFT) 3079 3080 Scheme_Hash_Table *scheme_map_constants_to_globals(void); 3081 const char *scheme_look_for_primitive(void *code); 3082 3083 Scheme_Object *scheme_flatten_begin(Scheme_Object *expr, Scheme_Object *append_onto); 3084 3085 Scheme_Object *scheme_make_svector(mzshort v, mzshort *a); 3086 3087 #define SCHEME_SVEC_LEN(obj) (((Scheme_Simple_Object *)(obj))->u.svector_val.len) 3088 #define SCHEME_SVEC_VEC(obj) (((Scheme_Simple_Object *)(obj))->u.svector_val.vec) 3089 3090 Scheme_Object *scheme_hash_percent_name(const char *name, int len); 3091 3092 Scheme_Object *scheme_make_branch(Scheme_Object *test, 3093 Scheme_Object *tbranch, 3094 Scheme_Object *fbranch); 3095 3096 Scheme_Env *scheme_make_empty_env(void); 3097 void scheme_prepare_exp_env(Scheme_Env *env); 3098 void scheme_prepare_template_env(Scheme_Env *env); 3099 void scheme_prepare_label_env(Scheme_Env *env); 3100 3101 int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int flags, 3102 Optimize_Info *opt_info, Optimize_Info *warn_info); 3103 #define OMITTABLE_RESOLVED 0x1 3104 #define OMITTABLE_KEEP_VARS 0x2 3105 #define OMITTABLE_KEEP_MUTABLE_VARS 0x4 3106 #define OMITTABLE_IGNORE_APPN_OMIT 0x8 3107 #define OMITTABLE_IGNORE_MAKE_STRUCT_TYPE 0x10 3108 3109 int scheme_might_invoke_call_cc(Scheme_Object *value); 3110 int scheme_is_liftable(Scheme_Object *o, Scheme_Hash_Tree *exclude_vars, int fuel, int as_rator, int or_escape); 3111 XFORM_NONGCING int scheme_is_functional_nonfailing_primitive(Scheme_Object *rator, int num_args, int expected_vals); 3112 XFORM_NONGCING int scheme_is_omitable_primitive(Scheme_Object *rator, int num_args); 3113 3114 typedef struct { 3115 int uses_super; 3116 int super_field_count; /* total fields (must == constructor-supplied fields) in superstruct */ 3117 int field_count; /* total fields in this struct */ 3118 int init_field_count; /* number of fields supplied to the constructor; usually == field_count */ 3119 int normal_ops; /* are selectors and predicates in the usual order? */ 3120 int indexed_ops; /* do selectors have the index built in (as opposed to taking an index argument)? */ 3121 int authentic; /* conservatively 0 is ok */ 3122 int sealed; /* conservatively 0 is ok */ 3123 int nonfail_constructor; 3124 int prefab; 3125 int num_gets, num_sets; 3126 int setter_fields; /* if indexed, bitmap for first 32 fields to indicate which have setters */ 3127 } Simple_Struct_Type_Info; 3128 3129 Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *app, int vals, int flags, 3130 int *_auto_e_depth, 3131 Simple_Struct_Type_Info *_stinfo, 3132 Scheme_Object **_parent_identity, 3133 Optimize_Info *info, 3134 Scheme_Hash_Table *top_level_table, 3135 Scheme_Object **runstack, int rs_delta, 3136 Scheme_Linklet *enclosing_linklet, 3137 Scheme_Object **_name, 3138 int fuel); 3139 int scheme_is_simple_make_struct_type_property(Scheme_Object *app, int vals, int flags, 3140 int *_has_guard, 3141 Optimize_Info *info, 3142 Scheme_Hash_Table *top_level_table, 3143 Scheme_Object **runstack, int rs_delta, 3144 Scheme_Linklet *enclosing_linklet, 3145 int fuel); 3146 #define CHECK_STRUCT_TYPE_RESOLVED 0x1 3147 #define CHECK_STRUCT_TYPE_ALWAYS_SUCCEED 0x2 3148 #define CHECK_STRUCT_TYPE_DELAY_AUTO_CHECK 0x4 3149 3150 Scheme_Object *scheme_intern_struct_proc_shape(int shape); 3151 intptr_t scheme_get_struct_proc_shape(int k, Simple_Struct_Type_Info *sinfo); 3152 Scheme_Object *scheme_make_struct_proc_shape(intptr_t k, Scheme_Object *identity); 3153 #define STRUCT_PROC_SHAPE_STRUCT 0 3154 #define STRUCT_PROC_SHAPE_CONSTR 1 3155 #define STRUCT_PROC_SHAPE_PRED 2 3156 #define STRUCT_PROC_SHAPE_GETTER 3 3157 #define STRUCT_PROC_SHAPE_SETTER 4 3158 #define STRUCT_PROC_SHAPE_OTHER 5 3159 #define STRUCT_PROC_SHAPE_MASK 0x7 3160 #define STRUCT_PROC_SHAPE_SEALED 0x8 3161 #define STRUCT_PROC_SHAPE_AUTHENTIC 0x10 3162 #define STRUCT_PROC_SHAPE_NONFAIL_CONSTR 0x20 3163 #define STRUCT_PROC_SHAPE_PREFAB 0x40 3164 #define STRUCT_PROC_SHAPE_SHIFT 7 3165 3166 typedef struct Scheme_Struct_Proc_Shape { 3167 Scheme_Object so; 3168 intptr_t mode; 3169 Scheme_Object *identity; /* sequence of pairs that identity the struct type */ 3170 } Scheme_Struct_Proc_Shape; 3171 #define SCHEME_PROC_SHAPE_MODE(obj) ((Scheme_Struct_Proc_Shape *)obj)->mode 3172 #define SCHEME_PROC_SHAPE_IDENTITY(obj) ((Scheme_Struct_Proc_Shape *)obj)->identity 3173 3174 Scheme_Object *scheme_intern_struct_prop_proc_shape(int shape); 3175 intptr_t scheme_get_struct_property_proc_shape(int k, int has_guard); 3176 Scheme_Object *scheme_make_struct_property_proc_shape(intptr_t k); 3177 #define STRUCT_PROP_PROC_SHAPE_PROP 0 3178 #define STRUCT_PROP_PROC_SHAPE_GUARDED_PROP 1 3179 #define STRUCT_PROP_PROC_SHAPE_PRED 2 3180 #define STRUCT_PROP_PROC_SHAPE_GETTER 3 3181 #define SCHEME_PROP_PROC_SHAPE_MODE(obj) ((Scheme_Small_Object *)obj)->u.int_val 3182 3183 Scheme_Object *scheme_get_or_check_procedure_shape(Scheme_Object *e, Scheme_Object *expected, int imprecise); 3184 intptr_t scheme_get_or_check_structure_shape(Scheme_Object *e, Scheme_Object *expected); 3185 int scheme_decode_struct_shape(Scheme_Object *shape, intptr_t *_v); 3186 intptr_t scheme_get_or_check_structure_property_shape(Scheme_Object *e, Scheme_Object *expected); 3187 int scheme_decode_struct_prop_shape(Scheme_Object *shape, intptr_t *_v); 3188 int scheme_closure_preserves_marks(Scheme_Object *p); 3189 int scheme_native_closure_preserves_marks(Scheme_Object *p); 3190 int scheme_native_closure_is_single_result(Scheme_Object *rator); 3191 3192 int scheme_get_eval_type(Scheme_Object *obj); 3193 3194 Scheme_Object *scheme_make_application(Scheme_Object *v, Optimize_Info *info); 3195 Scheme_Object *scheme_try_apply(Scheme_Object *f, Scheme_Object *args, Optimize_Info *info); 3196 int scheme_is_foldable_prim(Scheme_Object *f); 3197 3198 void scheme_define_parse(Scheme_Object *form, 3199 Scheme_Object **vars, Scheme_Object **val, 3200 Scheme_Comp_Env *env); 3201 3202 void scheme_validate_linklet(Mz_CPort *port, Scheme_Linklet *linklet); 3203 3204 typedef mzshort **Validate_TLS; 3205 struct Validate_Clearing; 3206 3207 void scheme_validate_closure(Mz_CPort *port, Scheme_Object *expr, 3208 char *closure_stack, Validate_TLS tls, 3209 int num_toplevels, int num_lifts, void *tl_use_map, 3210 mzshort *tl_state, mzshort tl_timestamp, 3211 int self_pos_in_closure, Scheme_Hash_Tree *procs, 3212 Scheme_Hash_Table **_st_ht); 3213 3214 #define TRACK_ILL_FORMED_CATCH_LINES 1 3215 #if TRACK_ILL_FORMED_CATCH_LINES 3216 void scheme_ill_formed(Mz_CPort *port, const char *file, int line); 3217 # define scheme_ill_formed_code(port) scheme_ill_formed(port, __FILE__, __LINE__) 3218 #else 3219 void scheme_ill_formed(Mz_CPort *port); 3220 # define scheme_ill_formed_code(port) scheme_ill_formed(port) 3221 #endif 3222 3223 Scheme_Object *scheme_make_lifted_defn(Scheme_Object *sys_wraps, Scheme_Object **_id, Scheme_Object *expr, Scheme_Comp_Env *env); 3224 3225 typedef struct Scheme_Marshal_Tables { 3226 MZTAG_IF_REQUIRED 3227 int pass, print_now; 3228 Scheme_Hash_Table *symtab; 3229 Scheme_Hash_Table *st_refs; 3230 Scheme_Object *st_ref_stack; 3231 Scheme_Hash_Table *intern_map; /* filled on first pass */ 3232 Scheme_Hash_Table *key_map; /* set after first pass, used on later passes */ 3233 Scheme_Hash_Table *delay_map; /* set during first pass, used on later passes */ 3234 Scheme_Object **cdata_map; /* for delay-load wrappers */ 3235 int cdata_counter; /* used with cdata_map */ 3236 intptr_t *shared_offsets; /* set in second pass */ 3237 Scheme_Hash_Table *path_cache; /* cache for path-to-relative resolution */ 3238 intptr_t sorted_keys_count; 3239 Scheme_Object **sorted_keys; 3240 } Scheme_Marshal_Tables; 3241 3242 typedef struct Scheme_Unmarshal_Tables { 3243 MZTAG_IF_REQUIRED 3244 struct CPort *rp; 3245 char *decoded; 3246 mzlonglong bytecode_hash; 3247 } Scheme_Unmarshal_Tables; 3248 3249 3250 typedef struct Scheme_Load_Delay { 3251 MZTAG_IF_REQUIRED 3252 Scheme_Object *path; 3253 intptr_t file_offset, size; 3254 uintptr_t symtab_size; 3255 Scheme_Object **symtab; 3256 intptr_t *shared_offsets; 3257 Scheme_Hash_Table *symtab_entries; /* `symtab` content to be skipped by resolve_references */ 3258 Scheme_Object *relto; 3259 Scheme_Unmarshal_Tables *ut; 3260 struct CPort *current_rp; 3261 int perma_cache; 3262 unsigned char *cached; 3263 Scheme_Object *cached_port; 3264 struct Scheme_Load_Delay *clear_bytes_prev; 3265 struct Scheme_Load_Delay *clear_bytes_next; 3266 int unsafe_ok; 3267 mzlonglong bytecode_hash; 3268 } Scheme_Load_Delay; 3269 3270 Scheme_Object *scheme_make_marshal_shared(Scheme_Object *v); 3271 3272 Scheme_Object *scheme_case_lambda_execute(Scheme_Object *expr); 3273 3274 Scheme_Object *scheme_module_jit(Scheme_Object *data); 3275 Scheme_Object *scheme_top_level_require_jit(Scheme_Object *data); 3276 Scheme_Object *scheme_case_lambda_jit(Scheme_Object *expr); 3277 3278 /*========================================================================*/ 3279 /* linklet instance and environment */ 3280 /*========================================================================*/ 3281 3282 /* A Scheme_Env acts as a wrapper for namespaces, which are externally 3283 implemented (via `scheme_startup_instance`). */ 3284 struct Scheme_Env { 3285 Scheme_Object so; /* scheme_env_type */ 3286 Scheme_Object *namespace; 3287 Scheme_Instance *instance; 3288 /* Used for setting up "extensions" */ 3289 int cross_phase; 3290 Scheme_Hash_Tree *protected; 3291 }; 3292 3293 /* A Scheme_Startup_Env holds tables of primitives */ 3294 struct Scheme_Startup_Env { 3295 Scheme_Object so; /* scheme_startup_env_type */ 3296 Scheme_Hash_Table *current_table; /* used during startup */ 3297 Scheme_Hash_Table *primitive_tables; /* symbol -> hash table */ 3298 Scheme_Hash_Table *all_primitives_table; 3299 Scheme_Hash_Table *primitive_ids_table; /* value -> integer */ 3300 }; 3301 3302 extern Scheme_Startup_Env * scheme_startup_env; 3303 3304 /* A Scheme_Instance is a linklet instance */ 3305 struct Scheme_Instance { 3306 Scheme_Inclhash_Object iso; /* 0x1 => inline only imprecise info into clients */ 3307 3308 union { 3309 Scheme_Bucket **a; /* for a small, predefined number of keys */ 3310 Scheme_Bucket_Table *bt; /* general case */ 3311 } variables; 3312 int array_size; /* 0 => hash mode */ 3313 3314 Scheme_Object *weak_self_link; /* for Scheme_Bucket_With_Home */ 3315 3316 Scheme_Hash_Tree *source_names; /* bucket symbol -> source symbol; initially copied from linklet */ 3317 3318 Scheme_Object *name; /* for reporting purposes */ 3319 Scheme_Object *data; 3320 }; 3321 3322 #define SCHEME_INSTANCE_FLAGS(obj) MZ_OPT_HASH_KEY(&(obj)->iso) 3323 #define SCHEME_INSTANCE_USE_IMPRECISE 0x1 3324 3325 Scheme_Instance *scheme_make_instance(Scheme_Object *name, Scheme_Object *data); 3326 Scheme_Bucket *scheme_instance_variable_bucket(Scheme_Object *symbol, Scheme_Instance *inst); 3327 Scheme_Bucket *scheme_instance_variable_bucket_or_null(Scheme_Object *symbol, Scheme_Instance *inst); 3328 3329 struct Scheme_Linklet 3330 { 3331 Scheme_Object so; /* scheme_linklet_type */ 3332 3333 Scheme_Object *name; /* for reporting purposes; FIXME: doesn't belong here? */ 3334 3335 Scheme_Object *importss; /* vector of vector of symbol (extenal names) */ 3336 Scheme_Object *import_shapes; /* optional flattened vector of values; records compiler assumptions */ 3337 int num_total_imports; /* total number of symbols in `importss` */ 3338 3339 /* The symbols in the `defns` arracy correspond to external names 3340 for the first `num_exports` entries. The remaining (non-exported) 3341 names should be adjusted on instantiation to avoid conflicts with 3342 any existing names; a #f value indicates an unused variable whose 3343 definition has been pruned. Unreadable symbols starting with "?" were 3344 generated for resolve-pass lifts. */ 3345 Scheme_Object *defns; /* vector of symbol-or-#f */ 3346 int num_exports; /* this many in the prefix of `defns` are exported */ 3347 int num_lifts; /* this many at the tail of `exports` are from resolve lifts */ 3348 3349 /* For error reporting, we can recover the source name from the 3350 symbol that is used in the bucket; this table is merged to the 3351 one in the instance, updating symbols as changed to avoid 3352 conflicts. */ 3353 Scheme_Hash_Tree *source_names; /* symbol (external name) -> symbol (internal or source name) */ 3354 3355 Scheme_Object *bodies; /* vector of definition or expression */ 3356 3357 int max_let_depth; 3358 int need_instance_access; /* whether the instance-access toplevel is needed */ 3359 3360 char jit_ready; /* true if the linklet is in has been prepared for the JIT */ 3361 char reject_eval; /* true when loaded without the root inspector, for example */ 3362 char serializable; /* record whether the linklet was intended to be serialized */ 3363 3364 Scheme_Hash_Table *constants; /* holds info about the linklet's body for inlining */ 3365 3366 Scheme_Prefix *static_prefix; /* non-NULL for a linklet compiled in static mode */ 3367 3368 Scheme_Object *native_lambdas; /* non-NULL => native lambdas to force-JIT on instantiation */ 3369 }; 3370 3371 #define SCHEME_DEFN_VAR_COUNT(d) (SCHEME_VEC_SIZE(d)-1) 3372 #define SCHEME_DEFN_RHS(d) (SCHEME_VEC_ELS(d)[0]) 3373 #define SCHEME_DEFN_VAR_(d, pos) (SCHEME_VEC_ELS(d)[(pos)+1]) 3374 #define SCHEME_DEFN_VAR(d, pos) ((Scheme_IR_Toplevel *)SCHEME_DEFN_VAR_(d, pos)) 3375 3376 /* Recycle some vector flags to use on definitions for the compiler, 3377 optimizer, and resolver to commuincate: */ 3378 #define SCHEME_DEFN_ALWAYS_INLINEP(d) SCHEME_IMMUTABLEP(d) 3379 #define SCHEME_SET_DEFN_ALWAYS_INLINE(d) SCHEME_SET_IMMUTABLE(d) 3380 #define SCHEME_DEFN_CAN_OMITP(d) SHARED_ALLOCATEDP(d) 3381 #define SCHEME_SET_DEFN_CAN_OMIT(d) SHARED_ALLOCATED_SET(d) 3382 3383 #define SCHEME_VARREF_FLAGS(pr) MZ_OPT_HASH_KEY(&((Scheme_Simple_Object *)pr)->iso) 3384 #define VARREF_IS_CONSTANT 0x1 3385 #define VARREF_FROM_UNSAFE 0x2 3386 #define VARREF_FLAGS_MASK (VARREF_IS_CONSTANT | VARREF_FROM_UNSAFE) 3387 3388 void scheme_addto_prim_instance(const char *name, Scheme_Object *obj, Scheme_Startup_Env *env); 3389 void scheme_addto_primitive_instance_by_symbol(Scheme_Object *name, Scheme_Object *obj, Scheme_Startup_Env *env); 3390 void scheme_switch_prim_instance(Scheme_Startup_Env *env, const char *name); 3391 void scheme_restore_prim_instance(Scheme_Startup_Env *env); 3392 3393 #define ADD_FOLDING_PRIM(name, func, a1, a2, a3, env) scheme_addto_prim_instance(name, scheme_make_folding_prim(func, name, a1, a2, a3), env) 3394 #define ADD_IMMED_PRIM(name, func, a1, a2, env) scheme_addto_prim_instance(name, scheme_make_immed_prim(func, name, a1, a2), env) 3395 #define ADD_PARAMETER(name, func, constant, env) scheme_addto_prim_instance(name, scheme_register_parameter(func, name, constant), env) 3396 #define ADD_PRIM_W_ARITY(name, func, a1, a2, env) scheme_addto_prim_instance(name, scheme_make_prim_w_arity(func, name, a1, a2), env) 3397 #define ADD_PRIM_W_ARITY2(name, func, a1, a2, a3, a4, env) scheme_addto_prim_instance(name, scheme_make_prim_w_arity2(func, name, a1, a2, a3, a4), env) 3398 #define ADD_NONCM_PRIM(name, func, a1, a2, env) scheme_addto_prim_instance(name, scheme_make_noncm_prim(func, name, a1, a2), env) 3399 3400 #define ADD_FOLDING_PRIM_UNARY_INLINED(name, func, a1, a2, a3, env) do {\ 3401 Scheme_Object *p; \ 3402 p = scheme_make_folding_prim(func, name, a1, a2, a3); \ 3403 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); \ 3404 scheme_addto_prim_instance(name, p, env); \ 3405 } while(0) 3406 3407 3408 THREAD_LOCAL_DECL(extern Scheme_Bucket_Table *scheme_namespace_to_env); 3409 Scheme_Env *scheme_get_current_namespace_as_env(); 3410 void scheme_set_current_namespace_as_env(Scheme_Env *env); 3411 3412 Scheme_Bucket_Table *scheme_clone_toplevel(Scheme_Bucket_Table *ht, Scheme_Env *home); 3413 3414 /*========================================================================*/ 3415 /* errors and exceptions */ 3416 /*========================================================================*/ 3417 3418 #define NOT_SUPPORTED_STR "unsupported on this platform" 3419 3420 intptr_t scheme_sprintf(char *s, intptr_t maxlen, const char *msg, ...); 3421 3422 int scheme_last_error_is_racket(int errid); 3423 3424 void scheme_read_err(Scheme_Object *port, const char *detail, ...); 3425 Scheme_Object *scheme_numr_err(Scheme_Object *complain, const char *detail, ...); 3426 3427 char *scheme_extract_indentation_suggestions(Scheme_Object *indentation); 3428 3429 void scheme_wrong_syntax(const char *where, 3430 Scheme_Object *local_form, 3431 Scheme_Object *form, 3432 const char *detail, ...); 3433 3434 void scheme_wrong_rator(Scheme_Object *rator, int argc, Scheme_Object **argv); 3435 3436 void scheme_wrong_chaperoned(const char *who, const char *what, Scheme_Object *orig, Scheme_Object *naya); 3437 3438 void scheme_rktio_error(const char *name, const char *what); 3439 3440 void scheme_non_fixnum_result(const char *name, Scheme_Object *o); 3441 3442 MZ_NORETURN void scheme_raise_out_of_memory(const char *where, const char *msg, ...); 3443 3444 char *scheme_make_srcloc_string(Scheme_Object *stx, intptr_t *len); 3445 3446 uintptr_t scheme_get_max_symbol_length(); 3447 void scheme_ensure_max_symbol_length(uintptr_t); 3448 3449 char *scheme_make_arity_expect_string(const char *map_name, 3450 Scheme_Object *proc, 3451 int argc, Scheme_Object **argv, 3452 intptr_t *len); 3453 3454 intptr_t scheme_extract_index(const char *name, int pos, int argc, 3455 Scheme_Object **argv, intptr_t top, int false_ok); 3456 3457 void scheme_get_substring_indices(const char *name, Scheme_Object *str, 3458 int argc, Scheme_Object **argv, 3459 int spos, int fpos, intptr_t *_start, intptr_t *_finish); 3460 void scheme_do_get_substring_indices(const char *name, Scheme_Object *str, 3461 int argc, Scheme_Object **argv, 3462 int spos, int fpos, intptr_t *_start, intptr_t *_finish, intptr_t len); 3463 3464 void scheme_out_of_range(const char *name, const char *what, const char *which, 3465 Scheme_Object *i, Scheme_Object *s, 3466 intptr_t start, intptr_t len); 3467 3468 const char *scheme_number_suffix(int); 3469 3470 const char *scheme_hostname_error(int err); 3471 3472 #define IMPROPER_LIST_FORM "illegal use of `.'" 3473 3474 int scheme_byte_string_has_null(Scheme_Object *o); 3475 int scheme_any_string_has_null(Scheme_Object *o); 3476 #define CHAR_STRING_W_NO_NULLS "string-no-nuls?" 3477 3478 int scheme_string_compare(Scheme_Object *s1, Scheme_Object *s2); 3479 int scheme_bytes_compare(Scheme_Object *s1, Scheme_Object *s2); 3480 3481 Scheme_Object *scheme_do_exit(int argc, Scheme_Object *argv[]); 3482 3483 Scheme_Object *scheme_make_arity(mzshort minc, mzshort maxc); 3484 Scheme_Object *scheme_make_arity_mask(intptr_t minc, intptr_t maxc); 3485 Scheme_Object *scheme_arity(Scheme_Object *p); 3486 Scheme_Object *scheme_arity_mask_to_arity(Scheme_Object *mask, int mode); 3487 3488 typedef struct { 3489 MZTAG_IF_REQUIRED 3490 Scheme_Object *syms[5]; 3491 int count; 3492 Scheme_Hash_Table *ht; 3493 } DupCheckRecord; 3494 3495 void scheme_begin_dup_symbol_check(DupCheckRecord *r); 3496 void scheme_dup_symbol_check(DupCheckRecord *r, const char *where, 3497 Scheme_Object *symbol, char *what, 3498 Scheme_Object *form); 3499 void scheme_check_identifier(const char *formname, Scheme_Object *id, 3500 const char *where, Scheme_Object *form); 3501 3502 Scheme_Object *scheme_get_stack_trace(Scheme_Object *mark_set); 3503 3504 XFORM_NONGCING int scheme_fast_check_arity(Scheme_Object *v, int a); 3505 Scheme_Object *scheme_get_or_check_arity(Scheme_Object *p, intptr_t a); 3506 Scheme_Object *scheme_get_arity_mask(Scheme_Object *p); 3507 int scheme_native_arity_check(Scheme_Object *closure, int argc); 3508 Scheme_Object *scheme_get_native_arity(Scheme_Object *closure, int mode); 3509 3510 #define SCHEME_MAX_FAST_ARITY_CHECK 29 3511 3512 struct Scheme_Logger { 3513 Scheme_Object so; 3514 Scheme_Object *name; 3515 Scheme_Logger *parent; 3516 int want_level; 3517 Scheme_Object *want_name_level_cache; /* vector */ 3518 Scheme_Object **root_timestamp; 3519 intptr_t local_timestamp; /* determines when want_level is up-to-date */ 3520 Scheme_Object *syslog_level; /* (list* <level-int> <name-sym> ... <level-int>) */ 3521 Scheme_Object *stderr_level; 3522 Scheme_Object *stdout_level; 3523 Scheme_Object *propagate_level; /* can be NULL */ 3524 Scheme_Object *readers; /* list of (cons (make-weak-box <reader>) <sema>) */ 3525 }; 3526 3527 typedef struct Scheme_Log_Reader { 3528 Scheme_Object so; 3529 Scheme_Object *level; /* (list* <level-int> <name-sym> ... <level-int>) */ 3530 Scheme_Object *sema; 3531 Scheme_Object *head, *tail; 3532 } Scheme_Log_Reader; 3533 3534 Scheme_Logger *scheme_make_logger(Scheme_Logger *parent, Scheme_Object *name); 3535 3536 char *scheme_optimize_context_to_string(Scheme_Object *context); 3537 3538 void scheme_write_proc_context(Scheme_Object *port, int print_width, 3539 Scheme_Object *name, 3540 Scheme_Object *src, Scheme_Object *line, 3541 Scheme_Object *col, Scheme_Object *pos, 3542 int generated); 3543 3544 #ifdef MZ_USE_MZRT 3545 void scheme_init_glib_log_queue(void); 3546 void scheme_check_glib_log_messages(void); 3547 #endif 3548 3549 /*========================================================================*/ 3550 /* filesystem utilities */ 3551 /*========================================================================*/ 3552 3553 #ifdef USE_TRANSITIONAL_64_FILE_OPS 3554 # define BIG_OFF_T_IZE(n) n ## 64 3555 # define mz_off_t off64_t 3556 #else 3557 # define BIG_OFF_T_IZE(n) n 3558 # if defined(DOS_FILE_SYSTEM) 3559 # define mz_off_t mzlonglong 3560 # else 3561 # define mz_off_t off_t 3562 # endif 3563 #endif 3564 3565 int scheme_is_relative_path(const char *s, intptr_t len, int kind); 3566 int scheme_is_complete_path(const char *s, intptr_t len, int kind); 3567 3568 #ifdef DOS_FILE_SYSTEM 3569 __declspec(dllexport) wchar_t *scheme_get_dll_path(wchar_t *s); 3570 __declspec(dllexport) void scheme_set_dll_path(wchar_t *p); 3571 #endif 3572 3573 Scheme_Object *scheme_get_file_directory(const char *filename); 3574 3575 char *scheme_normal_path_seps(char *s, int *_len, int delta); 3576 3577 int scheme_is_regular_file(char *filename); 3578 3579 void scheme_do_format(const char *procname, Scheme_Object *port, 3580 const mzchar *format, int flen, 3581 int fpos, int offset, int argc, Scheme_Object **argv); 3582 3583 Scheme_Object *scheme_default_load_extension(int argc, Scheme_Object **argv); 3584 3585 Scheme_Object *scheme_remove_current_directory_prefix(Scheme_Object *fn); 3586 3587 #ifdef DOS_FILE_SYSTEM 3588 int scheme_is_special_filename(const char *_f, int not_nul); 3589 # define NUM_SPECIAL_FILE_KINDS 30 3590 #endif 3591 3592 char *scheme_get_exec_path(void); 3593 Scheme_Object *scheme_get_run_cmd(void); 3594 3595 Scheme_Object *scheme_get_fd_identity(Scheme_Object *port, intptr_t fd, char *path, int noerr); 3596 3597 Scheme_Object *scheme_extract_relative_to(Scheme_Object *obj, Scheme_Object *dir, Scheme_Hash_Table *cache); 3598 3599 Scheme_Object *scheme_find_links_path(int argc, Scheme_Object *argv[]); 3600 3601 #ifdef DOS_FILE_SYSTEM 3602 wchar_t *scheme_path_to_wide_path(const char *who, const char *p); 3603 #endif 3604 3605 /*========================================================================*/ 3606 /* ports */ 3607 /*========================================================================*/ 3608 3609 THREAD_LOCAL_DECL(extern int scheme_active_but_sleeping); 3610 3611 struct rktio_fd_t; 3612 3613 typedef struct Scheme_Indexed_String { 3614 MZTAG_IF_REQUIRED 3615 char *string; 3616 int size; 3617 int index; 3618 union { 3619 int hot; /* output port */ 3620 int pos; /* input port */ 3621 } u; 3622 } Scheme_Indexed_String; 3623 3624 typedef struct Scheme_Pipe { 3625 MZTAG_IF_REQUIRED 3626 unsigned char *buf; 3627 intptr_t buflen, bufmax; 3628 intptr_t bufmaxextra; /* due to peeks, bufmax can effectively grow */ 3629 intptr_t bufstart, bufend; 3630 int eof; 3631 Scheme_Object *wakeup_on_read; 3632 Scheme_Object *wakeup_on_write; 3633 } Scheme_Pipe; 3634 3635 extern Scheme_Object *scheme_string_input_port_type; 3636 extern Scheme_Object *scheme_string_output_port_type; 3637 extern Scheme_Object *scheme_user_input_port_type; 3638 extern Scheme_Object *scheme_user_output_port_type; 3639 extern Scheme_Object *scheme_pipe_read_port_type; 3640 extern Scheme_Object *scheme_pipe_write_port_type; 3641 extern Scheme_Object *scheme_null_output_port_type; 3642 extern Scheme_Object *scheme_tcp_input_port_type; 3643 extern Scheme_Object *scheme_tcp_output_port_type; 3644 3645 THREAD_LOCAL_DECL(extern int scheme_force_port_closed); 3646 3647 void scheme_flush_orig_outputs(void); 3648 void scheme_flush_if_output_fds(Scheme_Object *o); 3649 Scheme_Object *scheme_file_stream_port_p(int, Scheme_Object *[]); 3650 Scheme_Object *scheme_terminal_port_p(int, Scheme_Object *[]); 3651 Scheme_Object *scheme_port_waiting_peer_p(int, Scheme_Object *[]); 3652 Scheme_Object *scheme_do_open_input_file(char *name, int offset, int argc, Scheme_Object *argv[], 3653 int internal, int for_module); 3654 Scheme_Object *scheme_do_open_output_file(char *name, int offset, int argc, Scheme_Object *argv[], int and_read, 3655 int internal); 3656 Scheme_Object *scheme_file_position(int argc, Scheme_Object *argv[]); 3657 Scheme_Object *scheme_file_position_star(int argc, Scheme_Object *argv[]); 3658 Scheme_Object *scheme_file_truncate(int argc, Scheme_Object *argv[]); 3659 Scheme_Object *scheme_file_buffer(int argc, Scheme_Object *argv[]); 3660 Scheme_Object *scheme_file_identity(int argc, Scheme_Object *argv[]); 3661 Scheme_Object *scheme_file_try_lock(int argc, Scheme_Object **argv); 3662 Scheme_Object *scheme_file_unlock(int argc, Scheme_Object **argv); 3663 3664 void scheme_reserve_file_descriptor(void); 3665 void scheme_release_file_descriptor(void); 3666 3667 int scheme_get_port_rktio_file_descriptor(Scheme_Object *p, struct rktio_fd_t **_fd); 3668 Scheme_Object *scheme_make_rktio_fd_input_port(struct rktio_fd_t *rfd, Scheme_Object *name); 3669 Scheme_Object *scheme_make_rktio_fd_output_port(struct rktio_fd_t *rfd, Scheme_Object *name, int read_too); 3670 3671 struct rktio_fd_t *scheme_get_port_rktio_socket(Scheme_Object *p); 3672 void scheme_rktio_socket_to_input_port(struct rktio_fd_t *fd, Scheme_Object *name, int takeover, 3673 Scheme_Object **_inp); 3674 void scheme_rktio_socket_to_output_port(struct rktio_fd_t *fd, Scheme_Object *name, int takeover, 3675 Scheme_Object **_outp); 3676 3677 void scheme_rktio_write_all(struct rktio_fd_t *fd, const char *data, intptr_t len); 3678 3679 void scheme_fs_change_properties(int *_supported, int *_scalable, int *_low_latency, int *_file_level); 3680 3681 THREAD_LOCAL_DECL(extern struct rktio_ltps_t *scheme_semaphore_fd_set); 3682 THREAD_LOCAL_DECL(extern Scheme_Hash_Table *scheme_semaphore_fd_mapping); 3683 3684 intptr_t scheme_get_byte_string_or_ch_put(const char *who, 3685 Scheme_Object *port, 3686 char *buffer, intptr_t offset, intptr_t size, 3687 int only_avail, 3688 int peek, Scheme_Object *peek_skip, 3689 Scheme_Object *unless_evt, 3690 Scheme_Object *target_ch); 3691 3692 Scheme_Object *scheme_get_special(Scheme_Object *inport, Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, int peek, 3693 Scheme_Hash_Table **for_read); 3694 Scheme_Object *scheme_get_ready_read_special(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table **ht); 3695 void scheme_set_in_read_mark(Scheme_Object *stxsrc, Scheme_Hash_Table **ht); 3696 Scheme_Object *scheme_get_special_proc(Scheme_Object *inport); 3697 void scheme_bad_time_for_special(const char *name, Scheme_Object *port); 3698 extern int scheme_special_ok; 3699 3700 int scheme_user_port_byte_probably_ready(Scheme_Input_Port *ip, Scheme_Schedule_Info *sinfo); 3701 int scheme_user_port_write_probably_ready(Scheme_Output_Port *op, Scheme_Schedule_Info *sinfo); 3702 int scheme_is_user_port(Scheme_Object *port); 3703 3704 int scheme_byte_ready_or_user_port_ready(Scheme_Object *p, Scheme_Schedule_Info *sinfo); 3705 3706 int scheme_pipe_char_count(Scheme_Object *p); 3707 Scheme_Object *scheme_port_name(Scheme_Object *p); 3708 intptr_t scheme_port_closed_p (Scheme_Object *port); 3709 3710 #define CURRENT_INPUT_PORT(config) scheme_get_param(config, MZCONFIG_INPUT_PORT) 3711 #define CURRENT_OUTPUT_PORT(config) scheme_get_param(config, MZCONFIG_OUTPUT_PORT) 3712 #define CHECK_PORT_CLOSED(who, kind, port, closed) if (closed) scheme_raise_exn(MZEXN_FAIL, "%s: " kind " port is closed", who); 3713 3714 #define MAX_UTF8_CHAR_BYTES 6 3715 3716 intptr_t scheme_redirect_write_bytes(Scheme_Output_Port *op, 3717 const char *str, intptr_t d, intptr_t len, 3718 int rarely_block, int enable_break); 3719 int scheme_redirect_write_special (Scheme_Output_Port *op, Scheme_Object *v, int nonblock); 3720 intptr_t scheme_redirect_get_or_peek_bytes(Scheme_Input_Port *orig_port, 3721 Scheme_Input_Port *port, 3722 char *buffer, intptr_t offset, intptr_t size, 3723 int nonblock, 3724 int peek, Scheme_Object *peek_skip, 3725 Scheme_Object *unless, 3726 Scheme_Schedule_Info *sinfo); 3727 3728 Scheme_Object *scheme_filesystem_change_evt(Scheme_Object *path, int flags, int report_errs); 3729 void scheme_filesystem_change_evt_cancel(Scheme_Object *evt, void *ignored_data); 3730 3731 void scheme_init_fd_semaphores(void); 3732 void scheme_release_fd_semaphores(void); 3733 3734 void scheme_check_fd_semaphores(void); 3735 Scheme_Object *scheme_rktio_fd_to_semaphore(struct rktio_fd_t *fd, int mode); 3736 3737 struct rktio_envvars_t; 3738 struct rktio_envvars_t *scheme_environment_variables_to_envvars(Scheme_Object *ev); 3739 3740 /*========================================================================*/ 3741 /* memory debugging */ 3742 /*========================================================================*/ 3743 3744 #ifdef MEMORY_COUNTING_ON 3745 extern intptr_t scheme_type_table_count; 3746 extern intptr_t scheme_misc_count; 3747 3748 Scheme_Object *scheme_dump_memory_count(int c, Scheme_Object *a[]); 3749 3750 intptr_t scheme_count_closure(Scheme_Object **o, mzshort len, Scheme_Hash_Table *ht); 3751 3752 intptr_t scheme_count_envbox(Scheme_Object *root, Scheme_Hash_Table *ht); 3753 intptr_t scheme_count_memory(Scheme_Object *root, Scheme_Hash_Table *ht); 3754 void scheme_count_input_port(Scheme_Object *port, intptr_t *s, intptr_t *e, Scheme_Hash_Table *ht); 3755 void scheme_count_output_port(Scheme_Object *port, intptr_t *s, intptr_t *e, Scheme_Hash_Table *ht); 3756 3757 void scheme_count_struct_info(Scheme_Object *o, intptr_t *s, intptr_t *e, Scheme_Hash_Table *ht); 3758 3759 #ifndef NO_OBJECT_SYSTEM 3760 void scheme_count_object(Scheme_Object *o, intptr_t *s, intptr_t *e, Scheme_Hash_Table *ht); 3761 void scheme_count_class(Scheme_Object *o, intptr_t *s, intptr_t *e, Scheme_Hash_Table *ht); 3762 void scheme_count_class_data(Scheme_Object *o, intptr_t *s, intptr_t *e, Scheme_Hash_Table *ht); 3763 void scheme_count_generic(Scheme_Object *o, intptr_t *s, intptr_t *e, Scheme_Hash_Table *ht); 3764 #endif 3765 #endif 3766 3767 /*========================================================================*/ 3768 /* miscellaneous */ 3769 /*========================================================================*/ 3770 3771 Scheme_Object *scheme_checked_car(int argc, Scheme_Object **argv); 3772 Scheme_Object *scheme_checked_cdr(int argc, Scheme_Object **argv); 3773 Scheme_Object *scheme_checked_caar(int argc, Scheme_Object **argv); 3774 Scheme_Object *scheme_checked_cadr(int argc, Scheme_Object **argv); 3775 Scheme_Object *scheme_checked_cdar(int argc, Scheme_Object **argv); 3776 Scheme_Object *scheme_checked_cddr(int argc, Scheme_Object **argv); 3777 Scheme_Object *scheme_checked_length(Scheme_Object *v); 3778 Scheme_Object *scheme_checked_list_tail(int argc, Scheme_Object **argv); 3779 Scheme_Object *scheme_checked_list_ref(int argc, Scheme_Object **argv); 3780 Scheme_Object *scheme_checked_mcar(int argc, Scheme_Object **argv); 3781 Scheme_Object *scheme_checked_mcdr(int argc, Scheme_Object **argv); 3782 Scheme_Object *scheme_checked_set_mcar (int argc, Scheme_Object *argv[]); 3783 Scheme_Object *scheme_checked_set_mcdr (int argc, Scheme_Object *argv[]); 3784 Scheme_Object *scheme_checked_vector_ref(int argc, Scheme_Object **argv); 3785 Scheme_Object *scheme_checked_vector_set(int argc, Scheme_Object **argv); 3786 Scheme_Object *scheme_checked_vector_star_ref(int argc, Scheme_Object **argv); 3787 Scheme_Object *scheme_checked_vector_star_set(int argc, Scheme_Object **argv); 3788 Scheme_Object *scheme_checked_vector_cas(int argc, Scheme_Object **argv); 3789 Scheme_Object *scheme_string_length(Scheme_Object *v); 3790 Scheme_Object *scheme_string_eq_2(Scheme_Object *str1, Scheme_Object *str2); 3791 Scheme_Object *scheme_checked_string_ref(int argc, Scheme_Object *argv[]); 3792 Scheme_Object *scheme_checked_string_set(int argc, Scheme_Object *argv[]); 3793 Scheme_Object *scheme_byte_string_length(Scheme_Object *v); 3794 Scheme_Object *scheme_byte_string_eq_2(Scheme_Object *str1, Scheme_Object *str2); 3795 Scheme_Object *scheme_checked_byte_string_ref(int argc, Scheme_Object *argv[]); 3796 Scheme_Object *scheme_checked_byte_string_set(int argc, Scheme_Object *argv[]); 3797 Scheme_Object *scheme_vector_length(Scheme_Object *v); 3798 Scheme_Object *scheme_vector_star_length(Scheme_Object *v); 3799 Scheme_Object *scheme_checked_flvector_ref(int argc, Scheme_Object **argv); 3800 Scheme_Object *scheme_checked_flvector_set(int argc, Scheme_Object **argv); 3801 Scheme_Object *scheme_flvector_length(Scheme_Object *v); 3802 Scheme_Object *scheme_checked_extflvector_ref(int argc, Scheme_Object **argv); 3803 Scheme_Object *scheme_checked_extflvector_set(int argc, Scheme_Object **argv); 3804 Scheme_Object *scheme_extflvector_length(Scheme_Object *v); 3805 Scheme_Vector *scheme_alloc_fxvector(intptr_t size); 3806 Scheme_Object *scheme_checked_fxvector_ref(int argc, Scheme_Object **argv); 3807 Scheme_Object *scheme_checked_fxvector_set(int argc, Scheme_Object **argv); 3808 Scheme_Object *scheme_fxvector_length(Scheme_Object *v); 3809 Scheme_Object *scheme_checked_real_part (int argc, Scheme_Object *argv[]); 3810 Scheme_Object *scheme_checked_imag_part (int argc, Scheme_Object *argv[]); 3811 Scheme_Object *scheme_checked_make_rectangular (int argc, Scheme_Object *argv[]); 3812 Scheme_Object *scheme_checked_flreal_part (int argc, Scheme_Object *argv[]); 3813 Scheme_Object *scheme_checked_flimag_part (int argc, Scheme_Object *argv[]); 3814 Scheme_Object *scheme_checked_make_flrectangular (int argc, Scheme_Object *argv[]); 3815 Scheme_Object *scheme_procedure_arity_includes(int argc, Scheme_Object *argv[]); 3816 Scheme_Object *scheme_checked_char_to_integer(int argc, Scheme_Object *argv[]); 3817 Scheme_Object *scheme_checked_integer_to_char(int argc, Scheme_Object *argv[]); 3818 Scheme_Object *scheme_checked_symbol_interned_p(int argc, Scheme_Object *argv[]); 3819 Scheme_Object *scheme_checked_make_vector(int argc, Scheme_Object *argv[]); 3820 Scheme_Object *scheme_checked_hash_ref(int argc, Scheme_Object *argv[]); 3821 Scheme_Object *scheme_checked_hash_count(int argc, Scheme_Object *argv[]); 3822 Scheme_Object *scheme_checked_hash_count(int argc, Scheme_Object *argv[]); 3823 Scheme_Object *scheme_unbox_star(Scheme_Object *b); 3824 void scheme_set_box_star(Scheme_Object *b, Scheme_Object *v); 3825 3826 Scheme_Object *scheme_check_not_undefined (int argc, Scheme_Object *argv[]); 3827 Scheme_Object *scheme_check_assign_not_undefined (int argc, Scheme_Object *argv[]); 3828 3829 Scheme_Object *scheme_chaperone_vector_copy(Scheme_Object *obj); 3830 Scheme_Object *scheme_chaperone_hash_table_copy(Scheme_Object *obj); 3831 3832 typedef Scheme_Object *(*Hash_Table_Element_Filter_Proc)(Scheme_Object *); 3833 Scheme_Object *scheme_chaperone_hash_table_filtered_copy(Scheme_Object *obj, 3834 Hash_Table_Element_Filter_Proc filter); 3835 3836 void scheme_bad_vec_index(char *name, Scheme_Object *i, 3837 const char *what, Scheme_Object *vec, 3838 intptr_t bottom, intptr_t len); 3839 3840 Scheme_Object *scheme_weak_box_value(Scheme_Object *obj); 3841 3842 Scheme_Bucket_Table *scheme_make_weak_equal_table(void); 3843 Scheme_Bucket_Table *scheme_make_weak_eqv_table(void); 3844 Scheme_Bucket_Table *scheme_make_nonlock_equal_bucket_table(void); 3845 3846 Scheme_Bucket_Table *scheme_make_ephemeron_equal_table(void); 3847 Scheme_Bucket_Table *scheme_make_ephemeron_eqv_table(void); 3848 3849 int scheme_hash_table_equal_rec(Scheme_Hash_Table *t1, Scheme_Object *orig_t1, 3850 Scheme_Hash_Table *t2, Scheme_Object *orig_t2, 3851 void *eql); 3852 int scheme_bucket_table_equal_rec(Scheme_Bucket_Table *t1, Scheme_Object *orig_t1, 3853 Scheme_Bucket_Table *t2, Scheme_Object *orig_t2, 3854 void *eql); 3855 int scheme_hash_tree_equal_rec(Scheme_Hash_Tree *t1, Scheme_Object *orig_t1, 3856 Scheme_Hash_Tree *t2, Scheme_Object *orig_t2, 3857 void *eql); 3858 Scheme_Object *scheme_hash_tree_copy(Scheme_Object *v); 3859 Scheme_Hash_Tree *scheme_make_hash_tree_of_type(Scheme_Type stype); 3860 3861 Scheme_Hash_Tree *scheme_make_hash_tree_placeholder(int kind); 3862 void scheme_hash_tree_tie_placeholder(Scheme_Hash_Tree *t, Scheme_Hash_Tree *base); 3863 XFORM_NONGCING Scheme_Hash_Tree *scheme_hash_tree_resolve_placeholder(Scheme_Hash_Tree *t); 3864 int scheme_hash_tree_kind(Scheme_Hash_Tree *t); 3865 int scheme_hash_tree_subset_of(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2); 3866 XFORM_NONGCING int scheme_eq_hash_tree_subset_of(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2); 3867 XFORM_NONGCING int scheme_eq_hash_tree_subset_match_of(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2); 3868 intptr_t scheme_hash_tree_key_hash(Scheme_Hash_Tree *t1); 3869 3870 void scheme_set_root_param(int p, Scheme_Object *v); 3871 3872 Scheme_Object *scheme_intern_exact_parallel_symbol(const char *name, uintptr_t len); 3873 Scheme_Object *scheme_symbol_append(Scheme_Object *s1, Scheme_Object *s2); 3874 Scheme_Object *scheme_copy_list(Scheme_Object *l); 3875 3876 Scheme_Object *scheme_append_strings(Scheme_Object *s1, Scheme_Object *s2); 3877 3878 Scheme_Object *scheme_unsafe_make_location(void); 3879 Scheme_Object *scheme_unsafe_make_srcloc(int argc, Scheme_Object **argv); 3880 3881 void scheme_reset_hash_table(Scheme_Hash_Table *ht, int *history); 3882 3883 XFORM_NONGCING void scheme_set_distinct_eq_hash(Scheme_Object *var2); 3884 3885 XFORM_NONGCING Scheme_Object *scheme_regexp_source(Scheme_Object *re); 3886 int scheme_regexp_is_byte(Scheme_Object *re); 3887 int scheme_regexp_is_pregexp(Scheme_Object *re); 3888 Scheme_Object *scheme_make_regexp(Scheme_Object *str, int byte, int pcre, int * volatile result_is_err_string); 3889 int scheme_is_pregexp(Scheme_Object *o); 3890 void scheme_clear_rx_buffers(void); 3891 3892 int scheme_regexp_match_p(Scheme_Object *regexp, Scheme_Object *target); 3893 3894 Scheme_Object *scheme_gensym(Scheme_Object *base); 3895 Scheme_Object *scheme_symbol_to_string(Scheme_Object *sym); 3896 3897 char *scheme_strdup_and_free(const char *str); 3898 3899 Scheme_Object *scheme_maybe_build_path(Scheme_Object *base, Scheme_Object *elem); 3900 3901 #ifdef SCHEME_BIG_ENDIAN 3902 # define MZ_UCS4_NAME "UCS-4BE" 3903 #else 3904 # define MZ_UCS4_NAME "UCS-4LE" 3905 #endif 3906 3907 #define SCHEME_SYM_UNINTERNEDP(o) (MZ_OPT_HASH_KEY(&((Scheme_Symbol *)(o))->iso) & 0x1) 3908 #define SCHEME_SYM_PARALLELP(o) (MZ_OPT_HASH_KEY(&((Scheme_Symbol *)(o))->iso) & 0x2) 3909 #define SCHEME_SYM_WEIRDP(o) (MZ_OPT_HASH_KEY(&((Scheme_Symbol *)(o))->iso) & 0x3) 3910 3911 Scheme_Object *scheme_current_library_collection_paths(int argc, Scheme_Object *argv[]); 3912 Scheme_Object *scheme_current_library_collection_links(int argc, Scheme_Object *argv[]); 3913 Scheme_Object *scheme_compiled_file_roots(int argc, Scheme_Object *argv[]); 3914 Scheme_Object *scheme_current_directory(int argc, Scheme_Object *argv[]); 3915 3916 int scheme_can_enable_write_permission(void); 3917 3918 #ifdef MZ_USE_JIT 3919 int scheme_can_inline_fp_op(); 3920 int scheme_can_inline_fp_comp(); 3921 #else 3922 # define scheme_can_inline_fp_op() 0 3923 # define scheme_can_inline_fp_comp() 0 3924 #endif 3925 3926 /* To suppress compiler warnings when it's difficult to avoid them otherwise: */ 3927 void scheme_unused_object(Scheme_Object*); 3928 void scheme_unused_intptr(intptr_t); 3929 3930 intptr_t scheme_check_overflow(intptr_t n, intptr_t m, intptr_t a); 3931 3932 Scheme_Object *scheme_make_environment_variables(Scheme_Hash_Tree *ht); 3933 void *scheme_environment_variables_to_block(Scheme_Object *env, int *_need_free); 3934 3935 int scheme_compare_equal(void *v1, void *v2); 3936 3937 typedef struct Scheme_Performance_State { 3938 intptr_t start, gc_start; 3939 intptr_t old_nested_delta, old_nested_gc_delta; 3940 } Scheme_Performance_State; 3941 3942 void scheme_performance_record_start(Scheme_Performance_State *perf_state); 3943 void scheme_performance_record_end(const char *who, Scheme_Performance_State *perf_state); 3944 3945 /*========================================================================*/ 3946 /* places */ 3947 /*========================================================================*/ 3948 3949 #if defined(MZ_USE_PLACES) 3950 # if defined(MZ_PRECISE_GC) 3951 typedef struct Scheme_Symbol_Parts { 3952 Scheme_Hash_Table *table; 3953 int kind; 3954 unsigned int len; 3955 const char *name; 3956 } Scheme_Symbol_Parts; 3957 3958 void scheme_spawn_master_place(); 3959 # endif 3960 #endif 3961 3962 typedef struct Scheme_Place_Async_Channel { 3963 Scheme_Object so; 3964 intptr_t in; 3965 intptr_t out; 3966 intptr_t count; 3967 intptr_t size; 3968 intptr_t delta; 3969 intptr_t wr_ref, rd_ref; /* ref counts on readers and writers */ 3970 #if defined(MZ_USE_PLACES) 3971 mzrt_mutex *lock; /* no allocation while this lock is held */ 3972 #endif 3973 Scheme_Object **msgs; 3974 void **msg_memory; 3975 Scheme_Object **msg_chains; /* lists embedded in message blocks; specially traversed during GC */ 3976 intptr_t mem_size; 3977 intptr_t reported_size; /* size reported to master GC; avoid reporting too often */ 3978 void *wakeup_signal; 3979 } Scheme_Place_Async_Channel; 3980 3981 typedef struct Scheme_Place_Bi_Channel_Link { 3982 /* all pointers; allocated as an array */ 3983 Scheme_Place_Async_Channel *sendch; 3984 Scheme_Place_Async_Channel *recvch; 3985 struct Scheme_Place_Bi_Channel_Link *prev, *next; 3986 } Scheme_Place_Bi_Channel_Link; 3987 3988 typedef struct Scheme_Place_Bi_Channel { 3989 Scheme_Object so; 3990 Scheme_Place_Bi_Channel_Link *link; 3991 } Scheme_Place_Bi_Channel; 3992 3993 void scheme_free_place_bi_channels(); 3994 3995 typedef struct Scheme_Place { 3996 Scheme_Object so; 3997 struct Scheme_Place_Object *place_obj; 3998 Scheme_Object *channel; 3999 Scheme_Custodian_Reference *mref; 4000 intptr_t result; /* set when place_obj becomes NULL */ 4001 #ifdef MZ_PRECISE_GC 4002 struct GC_Thread_Info *gc_info; /* managed by the GC */ 4003 #endif 4004 Scheme_Object *pumper_threads; /* Scheme_Vector of scheme threads */ 4005 4006 struct Scheme_Place *prev, *next; /* keeping a list of child places */ 4007 } Scheme_Place; 4008 4009 typedef struct Scheme_Place_Object { 4010 Scheme_Object so; 4011 #if defined(MZ_USE_PLACES) 4012 mzrt_mutex *lock; /* no allocation or place-channel locks while this lock is held */ 4013 mzrt_sema *pause; 4014 #endif 4015 char die; 4016 char dead; 4017 char pbreak; 4018 char pausing; 4019 intptr_t refcount; 4020 void *signal_handle; 4021 void *parent_signal_handle; /* set to NULL when the place terminates */ 4022 intptr_t result; /* initialized to 1, reset when parent_signal_handle becomes NULL */ 4023 4024 int id; 4025 intptr_t memory_use; /* set by inform hook on GC, used by GC for memory accounting */ 4026 intptr_t prev_notify_memory_use; /* if memory_use > use_factor * prev_notify_memory_use, alert parent */ 4027 double use_factor; 4028 intptr_t memory_limit; /* custodian-based limit on the place's memory use */ 4029 uintptr_t *parent_need_gc; /* ptr to a variable in parent to force a GC (triggering accounting) */ 4030 } Scheme_Place_Object; 4031 4032 typedef struct Scheme_Serialized_File_FD { 4033 Scheme_Object so; 4034 Scheme_Object *name; 4035 struct rktio_fd_transfer_t *fdt; 4036 intptr_t type; 4037 char flush_mode; 4038 } Scheme_Serialized_File_FD; 4039 4040 typedef struct Scheme_Serialized_Socket_FD { 4041 Scheme_Object so; 4042 Scheme_Object *name; 4043 struct rktio_fd_transfer_t *fdt; 4044 intptr_t type; 4045 } Scheme_Serialized_Socket_FD; 4046 4047 int scheme_get_serialized_fd_flags(Scheme_Object* p, Scheme_Serialized_File_FD *so); 4048 intptr_t scheme_dup_socket(intptr_t fd); 4049 intptr_t scheme_dup_file(intptr_t fd); 4050 void scheme_close_socket_fd(intptr_t fd); 4051 void scheme_close_file_fd(intptr_t fd); 4052 int scheme_os_pipe(intptr_t *fds, int near_index); 4053 void scheme_tcp_abandon_port(Scheme_Object *port); 4054 intptr_t scheme_socket_errno(); 4055 intptr_t scheme_errno(); 4056 void scheme_socket_to_input_port(intptr_t s, Scheme_Object *name, int takeover, Scheme_Object **_inp); 4057 void scheme_socket_to_output_port(intptr_t s, Scheme_Object *name, int takeover, Scheme_Object **_outp); 4058 4059 #define SCHEME_PLACE_OBJECTP(o) (SCHEME_TYPE(o) == scheme_place_object_type) 4060 4061 #ifdef MZ_USE_PLACES 4062 Scheme_Env *scheme_place_instance_init(void *stack_base, struct NewGC *, intptr_t memory_limit); 4063 #endif 4064 Scheme_Object *scheme_make_place_object(); 4065 void scheme_place_instance_destroy(int force); 4066 void scheme_kill_green_thread_timer(); 4067 void scheme_place_check_for_interruption(); 4068 void scheme_place_set_memory_use(intptr_t amt); 4069 void scheme_place_check_memory_use(); 4070 void scheme_clear_place_ifs_stack(); 4071 4072 Scheme_Object **scheme_extract_sorted_keys(Scheme_Object *ht); 4073 void scheme_sort_resolve_ir_local_array(Scheme_IR_Local **a, intptr_t count); 4074 4075 #ifdef MZ_USE_PLACES 4076 Scheme_Object *scheme_place_make_async_channel(); 4077 void scheme_place_async_channel_send(Scheme_Object *ch, Scheme_Object *uo); 4078 Scheme_Object *scheme_place_async_channel_receive(Scheme_Object *ch); 4079 int scheme_place_can_receive(); 4080 #endif 4081 int scheme_is_predefined_module_path(Scheme_Object *v); 4082 4083 void scheme_process_global_lock(void); 4084 void scheme_process_global_unlock(void); 4085 4086 Scheme_Object *scheme_expander_syntax_to_datum(Scheme_Object *v); 4087 int scheme_is_syntax(Scheme_Object *v); 4088 4089 #ifdef DOS_FILE_SYSTEM 4090 HANDLE scheme_dll_load_library(const char *s, const wchar_t *ws, int *_mode); 4091 void *scheme_dll_get_proc_address(HANDLE m, const char *name, int dll_mode); 4092 #endif 4093 4094 Scheme_Object *scheme_compile_target_check(int argc, Scheme_Object **argv); 4095 4096 #endif /* __mzscheme_private__ */ 4097