diff --git a/c-backend.scm b/c-backend.scm index d61b59a..aed69e6 100644 --- a/c-backend.scm +++ b/c-backend.scm @@ -483,13 +483,8 @@ ;; CPS context, so callee never returns to current function. ;; And even so, av[] is already copied into temporaries. (cond (caller-has-av? - (gen #t "C_word *av2;") - (gen #t "if(c >= " avl ") {") - (gen #t " av2=av; /* Re-use our own argvector */") - (gen #t "} else {") - (gen #t " av2=C_alloc(" avl ");") - (gen #t "}")) - (else (gen #t "C_word av2[" avl "];"))) + (gen #t "C_word *av2 = C_allocate_argvector(C_current_argvector_size, c, av, " avl ");")) + (else (gen #t "C_word *av2 = C_allocate_fresh_argvector(" avl ");"))) (when selfarg (gen #t "av2[0]=" selfarg ";")) (do ((j (if selfarg 1 0) (add1 j)) (args args (cdr args))) diff --git a/chicken.h b/chicken.h index 5a41f73..6b22eaf 100644 --- a/chicken.h +++ b/chicken.h @@ -1004,6 +1004,24 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret; #define C_heaptop ((C_word **)(&C_fromspace_top)) #define C_drop(n) (C_temporary_stack += (n)) #define C_alloc(n) ((C_word *)C_alloca((n) * sizeof(C_word))) + +#if 0 // set to "true" for backward compatible version to boot modified scheme +#define C_argvector_reuse_dflt(n) 0 // never, it does not exist +#define C_allocate_fresh_argvector(n) C_alloc(n) +#define C_allocate_argvector(as, c, av, avl) ( (c >= avl) ? av : C_force_allocate_fresh_argvector(avl)) +#else +#define C_MIN_AV_SIZE 4 +#define C_argvector_reuse_dflt(n) (C_current_argvector_size >= (n)) +#define C_argvector_flush() ((C_current_argvector_size = 0), (C_default_argvector_value = NULL)) +//gone #define C_allocate_fresh_argvector(n) (((n) <= C_MIN_AV_SIZE) ? ((C_current_argvector_size = (n)), C_default_argvector_value = C_alloc(n)) : (C_argvector_flush(), C_alloc(n))) +//gone #define C_force_allocate_fresh_argvector(n) ((C_current_argvector_size = ((n) > C_MIN_AV_SIZE ? (n) : C_MIN_AV_SIZE)), C_default_argvector_value = C_alloc(C_current_argvector_size)) +#define C_force_allocate_fresh_argvector(n) ((C_current_argvector_size = (n)), C_default_argvector_value = C_alloc(C_current_argvector_size)) +#define C_allocate_fresh_argvector(avl) (C_argvector_reuse_dflt(avl) ? C_default_argvector_value : C_force_allocate_fresh_argvector(avl)) +//gone #define C_allocate_argvector(as, c, av, avl) ( ((avl <= C_MIN_AV_SIZE) && (av == C_default_argvector_value)) ? av : (c >= avl) ? av : C_allocate_fresh_argvector(avl)) +// good #define C_allocate_argvector(as, c, av, avl) ((as) >= (avl) ? av : C_force_allocate_fresh_argvector(avl)) +#define C_allocate_argvector(as, c, av, avl) ( (c >= avl) ? av : (C_argvector_reuse_dflt(avl) ? av : C_force_allocate_fresh_argvector(avl))) +#endif + #if defined (__llvm__) && defined (__GNUC__) # if defined (__i386__) # define C_stack_pointer ({C_word *sp; __asm__ __volatile__("movl %%esp,%0":"=r"(sp):);sp;}) @@ -1219,7 +1237,8 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret; #define C_block_address(ptr, n, x) C_a_unsigned_int_to_num(ptr, n, x) #define C_offset_pointer(x, y) (C_pointer_address(x) + (y)) #define C_do_apply(c, av) ((C_proc)(void *)C_block_item((av)[0], 0))((c), (av)) -#define C_kontinue(k, r) do { C_word avk[ 2 ]; avk[ 0 ] = (k); avk[ 1 ] = (r); ((C_proc)(void *)C_block_item((k),0))(2, avk); } while(0) +// #define C_kontinue(k, r) do { C_word avk[ 2 ]; avk[ 0 ] = (k); avk[ 1 ] = (r); ((C_proc)(void *)C_block_item((k),0))(2, avk); } while(0) +#define C_kontinue(k, r) do { C_word *avk = C_allocate_fresh_argvector(2); avk[ 0 ] = (k); avk[ 1 ] = (r); ((C_proc)(void *)C_block_item((k),0))(2, avk); } while(0) #define C_fetch_byte(x, p) (((unsigned C_byte *)C_data_pointer(x))[ p ]) #define C_poke_integer(x, i, n) (C_set_block_item(x, C_unfix(i), C_num_to_int(n)), C_SCHEME_UNDEFINED) #define C_pointer_to_block(p, x) (C_set_block_item(p, 0, (C_word)C_data_pointer(x)), C_SCHEME_UNDEFINED) @@ -1595,6 +1614,7 @@ C_fctexport void C_register_debug_info(C_DEBUG_INFO *); /* Variables: */ +C_varextern C_TLS C_word *C_default_argvector_value, C_current_argvector_size; C_varextern C_TLS time_t C_startup_time_seconds; C_varextern C_TLS C_word *C_temporary_stack, diff --git a/runtime.c b/runtime.c index e5e1af8..ad91b95 100644 --- a/runtime.c +++ b/runtime.c @@ -325,6 +325,8 @@ typedef struct profile_bucket_struct /* Variables: */ +C_TLS C_word *C_default_argvector_value = NULL, C_current_argvector_size = 0; + C_TLS C_word *C_temporary_stack, *C_temporary_stack_bottom, @@ -1834,7 +1836,7 @@ void barf(int code, char *loc, ...) default: panic(C_text("illegal internal error code")); } - av = C_alloc(c + 4); + av = C_allocate_fresh_argvector(c + 4); if(!C_immediatep(err)) { va_start(v, loc); @@ -1984,7 +1986,7 @@ C_word C_fcall C_callback(C_word closure, int argc) C_memcpy(&prev, &C_restart, sizeof(C_restart)); callback_returned_flag = 0; chicken_is_running = 1; - av = C_alloc(argc + 2); + av = C_allocate_fresh_argvector(argc + 2); av[ 0 ] = closure; av[ 1 ] = k; /*XXX is the order of arguments an issue? */ @@ -2850,6 +2852,8 @@ C_regparm void C_fcall C_reclaim(void *trampoline, C_word c) TRACE_INFO *tinfo; C_DEBUG_INFO cell; + C_argvector_flush(); + /* assert(C_timer_interrupt_counter >= 0); */ if(pending_interrupts_count > 0 && C_interrupts_enabled) @@ -6215,6 +6219,7 @@ C_regparm C_word C_i_char_less_or_equal_p(C_word x, C_word y) /* Primitives: */ + void C_ccall C_apply(C_word c, C_word *av) { C_word @@ -6237,15 +6242,15 @@ void C_ccall C_apply(C_word c, C_word *av) len = C_unfix(C_u_i_length(lst)); av2_size = 2 + non_list_args + len; - if(!C_demand(av2_size)) + if(!C_argvector_reuse_dflt(av2_size) && !C_demand(av2_size)) C_save_and_reclaim((void *)C_apply, c, av); - av2 = ptr = C_alloc(av2_size); + av2 = ptr = C_allocate_argvector(C_current_argvector_size, c, av, av2_size); *(ptr++) = fn; *(ptr++) = k; if(non_list_args > 0) { - C_memcpy(ptr, av + 3, non_list_args * sizeof(C_word)); + C_memmove(ptr, av + 3, non_list_args * sizeof(C_word)); ptr += non_list_args; } @@ -6269,7 +6274,7 @@ void C_ccall C_call_cc(C_word c, C_word *av) *a = C_alloc(3), wrapper; void *pr = (void *)C_block_item(cont,0); - C_word av2[ 3 ]; + C_word *av2 = C_allocate_argvector(C_current_argvector_size, c, av, 3); if(C_immediatep(cont) || C_header_bits(cont) != C_CLOSURE_TYPE) barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-current-continuation", cont); @@ -6382,10 +6387,10 @@ void C_ccall C_apply_values(C_word c, C_word *av) len = C_unfix(C_u_i_length(lst)); n = len + 1; - if(!C_demand(n)) + if(!C_argvector_reuse_dflt(n) && !C_demand(n)) C_save_and_reclaim((void *)C_apply_values, c, av); - av2 = C_alloc(n); + av2 = C_allocate_argvector(C_current_argvector_size, c, av, n); av2[ 0 ] = k; ptr = av2 + 1; while(len--) { @@ -6471,11 +6476,11 @@ void C_ccall values_continuation(C_word c, C_word *av) closure = av[ 0 ], kont = C_block_item(closure, 1), k = C_block_item(closure, 2), - *av2 = C_alloc(c + 1); + *av2 = C_allocate_argvector(C_current_argvector_size, c, av, c + 1); + C_memmove(av2 + 2, av + 1, (c - 1) * sizeof(C_word)); av2[ 0 ] = kont; av2[ 1 ] = k; - C_memcpy(av2 + 2, av + 1, (c - 1) * sizeof(C_word)); C_do_apply(c + 1, av2); } @@ -7563,7 +7568,7 @@ void C_ccall C_flonum_rat(C_word c, C_word *av) double ga, gb; C_word ab[WORDS_PER_FLONUM * 2], *ap = ab; int i = 0; - C_word av2[ 4 ]; + C_word *av2 = C_allocate_argvector(C_current_argvector_size, c, av, 4); if (isnormal(fn)) { /* Calculate bit-length of the fractional part (ie, after decimal point) */ @@ -8230,7 +8235,7 @@ void C_ccall C_context_switch(C_word c, C_word *av) * vector should not be re-invoked(?), but it can be kept alive * during GC, so the mutated argvector/state slots may turn stale. */ - av2 = C_alloc(n); + av2 = C_force_allocate_fresh_argvector(n); C_memcpy(av2, (C_word *)state + 2, n * sizeof(C_word)); tp(n, av2); } @@ -8789,16 +8794,15 @@ void C_ccall C_locative_ref(C_word c, C_word *av) /* closure = av[ 0 ] */ k = av[ 1 ], loc, - *av2, - *ptr, val; - C_alloc_flonum; + *ptr, val, + ab[WORDS_PER_FLONUM], *a = ab; if(c != 3) C_bad_argc(c, 3); loc = av[ 2 ]; if(C_immediatep(loc) || C_block_header(loc) != C_LOCATIVE_TAG) - barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", loc); + barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-ref", loc); ptr = (C_word *)C_block_item(loc, 0); @@ -8811,22 +8815,11 @@ void C_ccall C_locative_ref(C_word c, C_word *av) case C_S8_LOCATIVE: C_kontinue(k, C_fix(*((char *)ptr))); case C_U16_LOCATIVE: C_kontinue(k, C_fix(*((unsigned short *)ptr))); case C_S16_LOCATIVE: C_kontinue(k, C_fix(*((short *)ptr))); - case C_U32_LOCATIVE: - av2 = C_alloc(4); - av2[ 0 ] = C_SCHEME_UNDEFINED; - av2[ 1 ] = k; - av2[ 2 ] = (C_word)(ptr - 1); - av2[ 3 ] = C_fix(0); - C_peek_unsigned_integer(3, av); - case C_S32_LOCATIVE: - av2 = C_alloc(4); - av2[ 0 ] = C_SCHEME_UNDEFINED; - av2[ 1 ] = k; - av2[ 2 ] = (C_word)(ptr - 1); - av2[ 3 ] = C_fix(0); - C_peek_signed_integer(3, av); - case C_F32_LOCATIVE: C_kontinue_flonum(k, *((float *)ptr)); - case C_F64_LOCATIVE: C_kontinue_flonum(k, *((double *)ptr)); + case C_U32_LOCATIVE: + C_kontinue(k, C_unsigned_int_to_num(&a, *((C_u32 *)ptr))); + case C_S32_LOCATIVE: C_kontinue(k, C_int_to_num(&a, *((C_s32 *)ptr))); + case C_F32_LOCATIVE: C_kontinue(k, C_flonum(&a, *((float *)ptr))); + case C_F64_LOCATIVE: C_kontinue(k, C_flonum(&a, *((double *)ptr))); default: panic(C_text("bad locative type")); } } @@ -9048,7 +9041,7 @@ void C_ccall C_call_with_cthulhu(C_word c, C_word *av) k = av[ 1 ], proc = av[ 2 ], *a = C_alloc(3), - av2[ 4 ]; + *av2 = C_allocate_argvector(C_current_argvector_size, c, av, 4); av2[ 0 ] = C_SCHEME_UNDEFINED; av2[ 1 ] = C_closure(&a, 1, (C_word)termination_continuation); /* k */