Hi,
the patch I sent is harmful. I forgot to reset chicken.h to "backward
compatible".
Attached a better version.
After patching, recompile to get a csc using the new macros. Then
change the first line in chicken.h to
#define USE_OLD_AV 0
recompile now.
Modify the second line to
#define USE_FIXED_DFLT ( !USE_OLD_AV && 0)
that is - change to 1 to 0 - if you want to try length-prefixed
argvector (I hope this still works).
Cheers
/Jörg
Am 28.02.2016 um 15:39 schrieb Jörg F. Wittenberger:
> Am 28.02.2016 um 15:19 schrieb Jörg F. Wittenberger:
>> BTW: currently a make check completed here. This one re-uses a single,
>> stack allocated argvector of TEMPORARY_STACK_SIZE whenever the current
>> code would do C_alloc or av2[N]. Notable exception C_context_switch.
>> Interestingly: while this is the simplest code one could use, the length
>> tagged argvector is consistently about 2% faster here on all tests so far.
>
> Attached the diff from my build tree to master.
>
> This obviously needs cleanup.
>
> But there needs to be a decision. Do we want simpler code at the
> expense of 2-5% runtime? Or do we want the length tagged version
> eventually?
diff --git a/c-backend.scm b/c-backend.scm
index 3f9846f..c96ae2c 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, 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 3694cd6..92d1296 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1,3 +1,5 @@
+#define USE_OLD_AV 1 // set to "true" for backward compatible version to boot modified chicken
+#define USE_FIXED_DFLT ( !USE_OLD_AV && 1)
/* chicken.h - General headerfile for compiler generated executables
;
; Copyright (c) 2008-2016, The CHICKEN Team
@@ -1010,6 +1012,43 @@ 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 USE_OLD_AV
+#define C_allocate_fresh_argvector(n) C_alloc(n)
+#define C_allocate_argvector(c, av, avl) ( (c >= avl) ? av : C_force_allocate_fresh_argvector(avl))
+// TBD: runtime internal
+#define C_argvector_flush() 0
+#define C_argvector_size(av) 0
+#define C_force_allocate_fresh_argvector(x) C_allocate_fresh_argvector(n)
+#elsif USE_FIXED_DFLT
+// TBD: runtime internal
+#define C_argvector_flush() 0 /* no longer used (C_default_argvector_value = NULL) */
+// remove this if this version is choosen, we don't need it, used only twice in runtime.c
+#define C_argvector_size(av) (C_default_argvector_value == av ? /*FIXME TEMPORARY_STACK_SIZE should be in runtime.c where it is known */ 4096 : 0)
+
+//#define C_force_allocate_fresh_argvector(avl) ( C_demand(avl) ? (C_default_argvector_value = C_alloc(avl)) : (C_argvector_flush(), C_temporary_stack))
+#define C_force_allocate_fresh_argvector(avl) (C_default_argvector_value = C_alloc(avl))
+
+// TDB: leave only these exported #defines
+//#define C_allocate_fresh_argvector(avl) ( /*FIXME should we assert(avl<=limit)*/ C_default_argvector_value != NULL ? C_default_argvector_value : C_force_allocate_fresh_argvector(avl))
+#define C_allocate_fresh_argvector(avl) C_default_argvector_value
+
+// TBD: try this, may be faster: #define C_allocate_argvector(c, av, avl) ( (c >= avl) ? av : C_force_allocate_fresh_argvector(avl))
+// TBD: try assert(C_default_argvector_value != NULL) here and never look back if this works. (deferred)
+//#define C_allocate_argvector(c, av, avl) ( (C_default_argvector_value != NULL) ? C_default_argvector_value : C_force_allocate_fresh_argvector(avl))
+#define C_allocate_argvector(c, av, avl) C_default_argvector_value
+
+#else
+#define C_argvector_reuse_dflt(n) ((C_default_argvector_value != NULL) && (C_default_argvector_value[0] >= (n)))
+#define C_argvector_flush() (C_default_argvector_value = NULL)
+#define C_force_allocate_fresh_argvector(n) ((C_default_argvector_value = C_alloc((n)+1)), *C_default_argvector_value=(n), C_default_argvector_value+1)
+#define C_allocate_fresh_argvector(avl) (C_argvector_reuse_dflt(avl) ? C_default_argvector_value+1 : C_force_allocate_fresh_argvector(avl))
+#define C_argvector_size(av) (av[-1])
+//#define C_allocate_argvector(c, av, avl) (C_argvector_size(av) >= (avl) ? av : C_force_allocate_fresh_argvector(avl))
+// should try this too (turned out to be faster here):
+#define C_allocate_argvector(c, av, avl) ((((c) >= (avl)) || (C_argvector_size(av) >= (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;})
@@ -1225,7 +1264,13 @@ 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)
+#if USE_OLD_AV
+#define C_kontinue_av(av, k, r) C_kontinue(k, r)
+#else
+#define C_kontinue_av(av, k, r) do { av[ 0 ] = (k); av[ 1 ] = (r); ((C_proc)(void *)C_block_item((k),0))(2, av); } while(0)
+#endif
#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)
@@ -1537,6 +1582,7 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
#define C_alloc_flonum C_word *___tmpflonum = C_alloc(WORDS_PER_FLONUM)
#define C_kontinue_flonum(k, n) C_kontinue((k), C_flonum(&___tmpflonum, (n)))
+#define C_kontinue_av_flonum(av, k, n) C_kontinue_av(av, (k), C_flonum(&___tmpflonum, (n)))
#define C_a_i_flonum_truncate(ptr, n, x) C_flonum(ptr, C_trunc(C_flonum_magnitude(x)))
#define C_a_i_flonum_ceiling(ptr, n, x) C_flonum(ptr, C_ceil(C_flonum_magnitude(x)))
@@ -1601,6 +1647,7 @@ C_fctexport void C_register_debug_info(C_DEBUG_INFO *);
/* Variables: */
+C_varextern C_TLS C_word *C_default_argvector_value;
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 8e89ea3..2345718 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_TLS C_word
*C_temporary_stack,
*C_temporary_stack_bottom,
@@ -1493,7 +1495,11 @@ C_word CHICKEN_run(void *toplevel)
if(!return_to_host) {
int argcount = C_temporary_stack_bottom - C_temporary_stack;
- C_word *p = C_alloc(argcount);
+#if USE_FIXED_DFLT
+ C_word *p = C_force_allocate_fresh_argvector(TEMPORARY_STACK_SIZE); // FIXME: this may be the only (or one out of two) allocation...maybe assert!
+#else
+ C_word *p = C_force_allocate_fresh_argvector(argcount);
+#endif
C_memcpy(p, C_temporary_stack, argcount * sizeof(C_word));
C_temporary_stack = C_temporary_stack_bottom;
((C_proc)C_restart_trampoline)(C_restart_c, p);
@@ -1834,7 +1840,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 +1990,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? */
@@ -2855,6 +2861,8 @@ C_regparm void C_fcall C_reclaim(void *trampoline, C_word c)
if(pending_interrupts_count > 0 && C_interrupts_enabled)
handle_interrupt(trampoline);
+ C_argvector_flush();
+
cell.enabled = 0;
cell.event = C_DEBUG_GC;
cell.loc = "<runtime>";
@@ -3766,7 +3774,7 @@ void handle_interrupt(void *trampoline)
{
C_word *p, h, reason, state, proc, n;
double c;
- C_word av[ 4 ];
+ C_word *av = C_allocate_fresh_argvector(4);
/* Build vector with context information: */
n = C_temporary_stack_bottom - C_temporary_stack;
@@ -4268,7 +4276,7 @@ void C_ccall C_stop_timer(C_word c, C_word *av)
info = C_vector(&a, 6, elapsed, gc_time, C_fix(mutation_count),
C_fix(tracked_mutation_count), C_fix(gc_count_1_total),
C_fix(gc_count_2));
- C_kontinue(k, info);
+ C_kontinue_av(av, k, info);
}
@@ -6215,6 +6223,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 +6246,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_size(av) < 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, 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 +6278,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, av, 3);
if(C_immediatep(cont) || C_header_bits(cont) != C_CLOSURE_TYPE)
barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-current-continuation", cont);
@@ -6297,7 +6306,7 @@ void C_ccall call_cc_wrapper(C_word c, C_word *av)
if(c != 3) C_bad_argc(c, 3);
result = av[ 2 ];
- C_kontinue(k, result);
+ C_kontinue_av(av, k, result);
}
@@ -6357,7 +6366,7 @@ void C_ccall C_values(C_word c, C_word *av)
}
else n = av[ 2 ];
- C_kontinue(k, n);
+ C_kontinue_av(av, k, n);
}
@@ -6382,10 +6391,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_size(av) < n) && !C_demand(n))
C_save_and_reclaim((void *)C_apply_values, c, av);
- av2 = C_alloc(n);
+ av2 = C_allocate_argvector(c, av, n);
av2[ 0 ] = k;
ptr = av2 + 1;
while(len--) {
@@ -6416,7 +6425,7 @@ void C_ccall C_apply_values(C_word c, C_word *av)
}
else barf(C_BAD_ARGUMENT_TYPE_ERROR, "apply", lst);
- C_kontinue(k, n);
+ C_kontinue_av(av, k, n);
}
@@ -6471,11 +6480,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, 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);
}
@@ -6486,7 +6495,8 @@ void C_ccall C_times(C_word c, C_word *av)
/* closure = av[ 0 ] */
k = av[ 1 ],
x, y,
- iresult = C_fix(1);
+ *av0=av,
+ iresult = C_fix(1);
double fresult;
C_alloc_flonum;
@@ -6512,7 +6522,7 @@ void C_ccall C_times(C_word c, C_word *av)
else barf(C_BAD_ARGUMENT_TYPE_ERROR, "*", x);
}
- C_kontinue(k, iresult);
+ C_kontinue_av(av0, k, iresult);
flonum_result:
while(c--) {
@@ -6525,7 +6535,7 @@ void C_ccall C_times(C_word c, C_word *av)
else barf(C_BAD_ARGUMENT_TYPE_ERROR, "*", x);
}
- C_kontinue_flonum(k, fresult);
+ C_kontinue_av_flonum(av0, k, fresult);
}
@@ -6564,6 +6574,7 @@ void C_ccall C_plus(C_word c, C_word *av)
/* closure = av[ 0 ] */
k = av[ 1 ],
x, y,
+ *av0=av,
iresult = C_fix(0);
double fresult;
C_alloc_flonum;
@@ -6590,7 +6601,7 @@ void C_ccall C_plus(C_word c, C_word *av)
else barf(C_BAD_ARGUMENT_TYPE_ERROR, "+", x);
}
- C_kontinue(k, iresult);
+ C_kontinue_av(av0, k, iresult);
flonum_result:
while(c--) {
@@ -6603,7 +6614,7 @@ void C_ccall C_plus(C_word c, C_word *av)
else barf(C_BAD_ARGUMENT_TYPE_ERROR, "+", x);
}
- C_kontinue_flonum(k, fresult);
+ C_kontinue_av_flonum(av0, k, fresult);
}
@@ -6642,6 +6653,7 @@ void C_ccall C_minus(C_word c, C_word *av)
/* closure = av[ 0 ] */
k = av[ 1 ],
x, y, n1,
+ *av0=av,
iresult;
double fresult;
int ff = 0;
@@ -6660,10 +6672,10 @@ void C_ccall C_minus(C_word c, C_word *av)
if(c == 3) {
if(!ff) {
- C_kontinue(k, C_fix(-C_unfix(n1)));
+ C_kontinue_av(av0, k, C_fix(-C_unfix(n1)));
}
else {
- C_kontinue_flonum(k, -fresult);
+ C_kontinue_av_flonum(av0, k, -fresult);
}
}
@@ -6691,7 +6703,7 @@ void C_ccall C_minus(C_word c, C_word *av)
else barf(C_BAD_ARGUMENT_TYPE_ERROR, "-", x);
}
- C_kontinue(k, iresult);
+ C_kontinue_av(av0, k, iresult);
flonum_result:
while(c--) {
@@ -6704,7 +6716,7 @@ void C_ccall C_minus(C_word c, C_word *av)
else barf(C_BAD_ARGUMENT_TYPE_ERROR, "-", x);
}
- C_kontinue_flonum(k, fresult);
+ C_kontinue_av_flonum(av0, k, fresult);
}
@@ -6744,6 +6756,7 @@ void C_ccall C_divide(C_word c, C_word *av)
/* closure = av[ 0 ] */
k = av[ 1 ],
n1, n2,
+ *av0=av,
iresult, n3;
int fflag;
double fresult, f2;
@@ -6771,7 +6784,7 @@ void C_ccall C_divide(C_word c, C_word *av)
}
else {
if(iresult == 0) barf(C_DIVISION_BY_ZERO_ERROR, "/");
- else if(iresult == 1) C_kontinue(k, C_fix(1));
+ else if(iresult == 1) C_kontinue_av(av0, k, C_fix(1));
fresult = 1.0 / (double)iresult;
fflag = 1;
@@ -6825,11 +6838,11 @@ void C_ccall C_divide(C_word c, C_word *av)
cont:
if(fflag) {
- C_kontinue_flonum(k, fresult);
+ C_kontinue_av_flonum(av0, k, fresult);
}
else n1 = C_fix(iresult);
- C_kontinue(k, n1);
+ C_kontinue_av(av0, k, n1);
}
@@ -6884,6 +6897,7 @@ void C_ccall C_nequalp(C_word c, C_word *av)
C_word
/* closure = av[ 0 ] */
k = av[ 1 ],
+ *av0=av,
x, i2, f, fflag, ilast;
double flast, f2;
@@ -6935,7 +6949,7 @@ void C_ccall C_nequalp(C_word c, C_word *av)
}
cont:
- C_kontinue(k, C_mk_bool(f));
+ C_kontinue_av(av0, k, C_mk_bool(f));
}
@@ -6966,6 +6980,7 @@ void C_ccall C_greaterp(C_word c, C_word *av)
C_word
/* closure = av[ 0 ] */
k = av[ 1 ],
+ *av0=av,
x, i2, f, fflag, ilast;
double flast, f2;
@@ -7017,7 +7032,7 @@ void C_ccall C_greaterp(C_word c, C_word *av)
}
cont:
- C_kontinue(k, C_mk_bool(f));
+ C_kontinue_av(av0, k, C_mk_bool(f));
}
@@ -7048,6 +7063,7 @@ void C_ccall C_lessp(C_word c, C_word *av)
C_word
/* closure = av[ 0 ] */
k = av[ 1 ],
+ *av0=av,
x, i2, f, fflag, ilast;
double flast, f2;
@@ -7099,7 +7115,7 @@ void C_ccall C_lessp(C_word c, C_word *av)
}
cont:
- C_kontinue(k, C_mk_bool(f));
+ C_kontinue_av(av0, k, C_mk_bool(f));
}
@@ -7130,6 +7146,7 @@ void C_ccall C_greater_or_equal_p(C_word c, C_word *av)
C_word
/* closure = av[ 0 ] */
k = av[ 1 ],
+ *av0=av,
x, i2, f, fflag, ilast;
double flast, f2;
@@ -7181,7 +7198,7 @@ void C_ccall C_greater_or_equal_p(C_word c, C_word *av)
}
cont:
- C_kontinue(k, C_mk_bool(f));
+ C_kontinue_av(av0, k, C_mk_bool(f));
}
@@ -7212,6 +7229,7 @@ void C_ccall C_less_or_equal_p(C_word c, C_word *av)
C_word
/* closure = av[ 0 ] */
k = av[ 1 ],
+ *av0=av,
x, i2, f, fflag, ilast;
double flast, f2;
@@ -7263,7 +7281,7 @@ void C_ccall C_less_or_equal_p(C_word c, C_word *av)
}
cont:
- C_kontinue(k, C_mk_bool(f));
+ C_kontinue_av(av0, k, C_mk_bool(f));
}
@@ -7317,9 +7335,9 @@ void C_ccall C_expt(C_word c, C_word *av)
r = (C_word)m1;
if(r == m1 && (n1 & C_FIXNUM_BIT) && (n2 & C_FIXNUM_BIT) && modf(m1, &m2) == 0.0 && C_fitsinfixnump(r))
- C_kontinue(k, C_fix(r));
+ C_kontinue_av(av, k, C_fix(r));
- C_kontinue_flonum(k, m1);
+ C_kontinue_av_flonum(av, k, m1);
}
@@ -7363,7 +7381,7 @@ void C_ccall gc_2(C_word c, C_word *av)
{
C_word k = av[ 0 ];
- C_kontinue(k, C_fix((C_uword)C_fromspace_limit - (C_uword)C_fromspace_top));
+ C_kontinue(k, C_fix((C_uword)C_fromspace_limit - (C_uword)C_fromspace_top)); // no av-reuse
}
@@ -7409,7 +7427,7 @@ void C_ccall C_open_file_port(C_word c, C_word *av)
}
C_set_block_item(port, 0, (C_word)fp);
- C_kontinue(k, C_mk_bool(fp != NULL));
+ C_kontinue_av(av, k, C_mk_bool(fp != NULL));
}
@@ -7508,7 +7526,7 @@ void C_ccall allocate_vector_2(C_word c, C_word *av)
C_memset(v0, C_character_code(init), size);
}
- C_kontinue(k, v);
+ C_kontinue(k, v); // Note: this argvector may not be reusable (see allocate_vector)
}
@@ -7536,7 +7554,7 @@ void C_ccall C_string_to_symbol(C_word c, C_word *av)
if(!C_truep(s = lookup(key, len, name, symbol_table)))
s = add_symbol(&a, key, string, symbol_table);
- C_kontinue(k, s);
+ C_kontinue_av(av, k, s);
}
@@ -7549,7 +7567,7 @@ void C_ccall C_flonum_fraction(C_word c, C_word *av)
double i, fn = C_flonum_magnitude(n);
C_alloc_flonum;
- C_kontinue_flonum(k, modf(fn, &i));
+ C_kontinue_av_flonum(av, k, modf(fn, &i));
}
@@ -7563,7 +7581,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, av, 4);
if (isnormal(fn)) {
/* Calculate bit-length of the fractional part (ie, after decimal point) */
@@ -7650,7 +7668,7 @@ void C_ccall C_quotient(C_word c, C_word *av)
barf(C_DIVISION_BY_ZERO_ERROR, "quotient");
result = C_fix(C_unfix(n1) / n2);
- C_kontinue(k, result);
+ C_kontinue_av(av, k, result);
}
else if(!C_immediatep(n2) && C_block_header(n2) == C_FLONUM_TAG) {
f1 = (double)C_unfix(n1);
@@ -7680,7 +7698,7 @@ void C_ccall C_quotient(C_word c, C_word *av)
barf(C_DIVISION_BY_ZERO_ERROR, "quotient");
modf(f1 / f2, &r);
- C_kontinue_flonum(k, r);
+ C_kontinue_av_flonum(av, k, r);
}
@@ -8043,7 +8061,7 @@ void C_ccall C_number_to_string(C_word c, C_word *av)
radix = C_strlen(p);
a = C_alloc((C_bytestowords(radix) + 1));
radix = C_string(&a, radix, p);
- C_kontinue(k, radix);
+ C_kontinue_av(av, k, radix);
}
@@ -8066,7 +8084,7 @@ void C_ccall C_fixnum_to_string(C_word c, C_word *av)
n = C_strlen(buffer);
a = C_alloc(C_bytestowords(n) + 1);
s = C_string2(&a, buffer);
- C_kontinue(k, s);
+ C_kontinue_av(av, k, s);
}
@@ -8076,6 +8094,7 @@ void C_ccall C_make_structure(C_word c, C_word *av)
/* closure = av[ 0 ] */
k = av[ 1 ],
type = av[ 2 ],
+ *av0 = av,
size = c - 3,
*s, s0;
@@ -8091,7 +8110,7 @@ void C_ccall C_make_structure(C_word c, C_word *av)
while(size--)
*(s++) = *(av++);
- C_kontinue(k, s0);
+ C_kontinue_av(av0, k, s0);
}
@@ -8109,7 +8128,7 @@ void C_ccall C_make_symbol(C_word c, C_word *av)
*(a++) = C_SCHEME_UNBOUND;
*(a++) = name;
*a = C_SCHEME_END_OF_LIST;
- C_kontinue(k, s0);
+ C_kontinue_av(av, k, s0);
}
@@ -8123,7 +8142,7 @@ void C_ccall C_make_pointer(C_word c, C_word *av)
p;
p = C_mpointer(&a, NULL);
- C_kontinue(k, p);
+ C_kontinue_av(av, k, p);
}
@@ -8138,7 +8157,7 @@ void C_ccall C_make_tagged_pointer(C_word c, C_word *av)
p;
p = C_taggedmpointer(&a, tag, NULL);
- C_kontinue(k, p);
+ C_kontinue_av(av, k, p);
}
@@ -8165,7 +8184,7 @@ void C_ccall generic_trampoline(C_word c, C_word *av)
{
C_word k = av[ 0 ];
- C_kontinue(k, C_SCHEME_UNDEFINED);
+ C_kontinue(k, C_SCHEME_UNDEFINED); // no av-reuse! see C_ensure_heap_reserve
}
@@ -8200,7 +8219,7 @@ void C_ccall C_get_symbol_table_info(C_word c, C_word *av)
d1 = compute_symbol_table_load(&d2, &total);
x = C_flonum(&a, d1); /* load */
y = C_flonum(&a, d2); /* avg bucket length */
- C_kontinue(k, C_vector(&a, 4, x, y, C_fix(total), C_fix(n)));
+ C_kontinue_av(av, k, C_vector(&a, 4, x, y, C_fix(total), C_fix(n)));
}
@@ -8212,7 +8231,7 @@ void C_ccall C_get_memory_info(C_word c, C_word *av)
ab[ 3 ],
*a = ab;
- C_kontinue(k, C_vector(&a, 2, C_fix(heap_size), C_fix(stack_size)));
+ C_kontinue_av(av, k, C_vector(&a, 2, C_fix(heap_size), C_fix(stack_size)));
}
@@ -8230,7 +8249,14 @@ 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.
*/
+#if USE_FIXED_DFLT
+ // like av2 = C_force_allocate_fresh_argvector(TEMPORARY_STACK_SIZE); but no flush
+ //FIXME TBD: craft a macro for this case.
av2 = C_alloc(n);
+#else
+ //FIXME: remove this bad idea,
+ av2 = C_force_allocate_fresh_argvector(n);
+#endif
C_memcpy(av2, (C_word *)state + 2, n * sizeof(C_word));
tp(n, av2);
}
@@ -8247,10 +8273,10 @@ void C_ccall C_peek_signed_integer(C_word c, C_word *av)
C_alloc_flonum;
if((x & C_INT_SIGN_BIT) != (((C_uword)x << 1) & C_INT_SIGN_BIT)) {
- C_kontinue_flonum(k, (double)x);
+ C_kontinue_av_flonum(av, k, (double)x);
}
- C_kontinue(k, C_fix(x));
+ C_kontinue_av(av, k, C_fix(x));
}
@@ -8265,10 +8291,10 @@ void C_ccall C_peek_unsigned_integer(C_word c, C_word *av)
C_alloc_flonum;
if((x & C_INT_SIGN_BIT) || (((C_uword)x << 1) & C_INT_SIGN_BIT)) {
- C_kontinue_flonum(k, (double)(C_uword)x);
+ C_kontinue_av_flonum(av, k, (double)(C_uword)x);
}
- C_kontinue(k, C_fix(x));
+ C_kontinue_av(av, k, C_fix(x));
}
@@ -8292,7 +8318,7 @@ void C_ccall C_decode_seconds(C_word c, C_word *av)
else tmt = C_gmtime(&tsecs);
if(tmt == NULL)
- C_kontinue(k, C_SCHEME_FALSE);
+ C_kontinue_av(av, k, C_SCHEME_FALSE);
info = C_vector(&a, 10, C_fix(tmt->tm_sec), C_fix(tmt->tm_min), C_fix(tmt->tm_hour),
C_fix(tmt->tm_mday), C_fix(tmt->tm_mon), C_fix(tmt->tm_year),
@@ -8307,7 +8333,7 @@ void C_ccall C_decode_seconds(C_word c, C_word *av)
C_fix(mode == C_SCHEME_FALSE ? timezone : 0) /* does not account for DST */
#endif
);
- C_kontinue(k, info);
+ C_kontinue_av(av, k, info);
}
@@ -8333,7 +8359,7 @@ void C_ccall C_machine_byte_order(C_word c, C_word *av)
a = C_alloc(2 + C_bytestowords(strlen(str)));
s = C_string2(&a, str);
- C_kontinue(k, s);
+ C_kontinue_av(av, k, s);
}
@@ -8349,7 +8375,7 @@ void C_ccall C_machine_type(C_word c, C_word *av)
a = C_alloc(2 + C_bytestowords(strlen(C_MACHINE_TYPE)));
s = C_string2(&a, C_MACHINE_TYPE);
- C_kontinue(k, s);
+ C_kontinue_av(av, k, s);
}
@@ -8365,7 +8391,7 @@ void C_ccall C_software_type(C_word c, C_word *av)
a = C_alloc(2 + C_bytestowords(strlen(C_SOFTWARE_TYPE)));
s = C_string2(&a, C_SOFTWARE_TYPE);
- C_kontinue(k, s);
+ C_kontinue_av(av, k, s);
}
@@ -8381,7 +8407,7 @@ void C_ccall C_build_platform(C_word c, C_word *av)
a = C_alloc(2 + C_bytestowords(strlen(C_BUILD_PLATFORM)));
s = C_string2(&a, C_BUILD_PLATFORM);
- C_kontinue(k, s);
+ C_kontinue_av(av, k, s);
}
@@ -8397,7 +8423,7 @@ void C_ccall C_software_version(C_word c, C_word *av)
a = C_alloc(2 + C_bytestowords(strlen(C_SOFTWARE_VERSION)));
s = C_string2(&a, C_SOFTWARE_VERSION);
- C_kontinue(k, s);
+ C_kontinue_av(av, k, s);
}
@@ -8412,10 +8438,10 @@ void C_ccall C_register_finalizer(C_word c, C_word *av)
proc = av[ 3 ];
if(C_immediatep(x) || (!C_in_stackp(x) && !C_in_heapp(x))) /* not GCable? */
- C_kontinue(k, x);
+ C_kontinue_av(av, k, x);
C_do_register_finalizer(x, proc);
- C_kontinue(k, x);
+ C_kontinue_av(av, k, x);
}
@@ -8487,7 +8513,7 @@ void C_ccall C_set_dlopen_flags(C_word c, C_word *av)
#if !defined(NO_DLOAD2) && defined(HAVE_DLFCN_H)
dlopen_flags = (C_truep(now) ? RTLD_NOW : RTLD_LAZY) | (C_truep(global) ? RTLD_GLOBAL : RTLD_LOCAL);
#endif
- C_kontinue(k, C_SCHEME_UNDEFINED);
+ C_kontinue_av(av, k, C_SCHEME_UNDEFINED);
}
@@ -8505,7 +8531,7 @@ void C_ccall C_dload(C_word c, C_word *av)
C_save_and_reclaim_args((void *)dload_2, 3, k, name, entry);
#endif
- C_kontinue(k, C_SCHEME_FALSE);
+ C_kontinue_av(av, k, C_SCHEME_FALSE);
}
@@ -8516,14 +8542,13 @@ void C_ccall C_dload(C_word c, C_word *av)
#if !defined(NO_DLOAD2) && defined(HAVE_DL_H) && !defined(DLOAD_2_DEFINED)
# ifdef __hpux__
# define DLOAD_2_DEFINED
-void C_ccall dload_2(C_word c, C_word *av0)
+void C_ccall dload_2(C_word c, C_word *av)
{
void *handle, *p;
C_word
- entry = av0[ 0 ],
- name = av0[ 1 ],
- k = av0[ 2 ],,
- av[ 2 ];
+ entry = av[ 0 ],
+ name = av[ 1 ],
+ k = av[ 2 ]:
C_char *mname = (C_char *)C_data_pointer(name);
/*
@@ -8559,7 +8584,7 @@ void C_ccall dload_2(C_word c, C_word *av0)
C_dlerror = (char *) C_strerror(errno);
}
- C_kontinue(k, C_SCHEME_FALSE);
+ C_kontinue_av(av, k, C_SCHEME_FALSE);
}
# endif
#endif
@@ -8568,14 +8593,13 @@ void C_ccall dload_2(C_word c, C_word *av0)
#if !defined(NO_DLOAD2) && defined(HAVE_DLFCN_H) && !defined(DLOAD_2_DEFINED)
# ifndef __hpux__
# define DLOAD_2_DEFINED
-void C_ccall dload_2(C_word c, C_word *av0)
+void C_ccall dload_2(C_word c, C_word *av)
{
void *handle, *p, *p2;
C_word
- entry = av0[ 0 ],
- name = av0[ 1 ],
- k = av0[ 2 ],
- av[ 2 ];
+ entry = av[ 0 ],
+ name = av[ 1 ],
+ k = av[ 2 ];
C_char *topname = (C_char *)C_data_pointer(entry);
C_char *mname = (C_char *)C_data_pointer(name);
C_char *tmp;
@@ -8613,7 +8637,7 @@ void C_ccall dload_2(C_word c, C_word *av0)
}
C_dlerror = (char *)dlerror();
- C_kontinue(k, C_SCHEME_FALSE);
+ C_kontinue_av(av, k, C_SCHEME_FALSE);
}
# endif
#endif
@@ -8621,15 +8645,14 @@ void C_ccall dload_2(C_word c, C_word *av0)
#if !defined(NO_DLOAD2) && (defined(HAVE_LOADLIBRARY) && defined(HAVE_GETPROCADDRESS)) && !defined(DLOAD_2_DEFINED)
# define DLOAD_2_DEFINED
-void C_ccall dload_2(C_word c, C_word *av0)
+void C_ccall dload_2(C_word c, C_word *av)
{
HINSTANCE handle;
FARPROC p = NULL, p2;
C_word
- entry = av0[ 0 ],
- name = av0[ 1 ],
- k = av0[ 2 ],
- av[ 2 ];
+ entry = av[ 0 ],
+ name = av[ 1 ],
+ k = av[ 2 ];
C_char *topname = (C_char *)C_data_pointer(entry);
C_char *mname = (C_char *)C_data_pointer(name);
@@ -8639,7 +8662,7 @@ void C_ccall dload_2(C_word c, C_word *av0)
int l = C_header_size(name);
if (C_strncasecmp(".dll", n+l-5, 4) &&
C_strncasecmp(".so", n+l-4, 3))
- C_kontinue(k, C_SCHEME_FALSE);
+ C_kontinue_av(av, k, C_SCHEME_FALSE);
}
if((handle = LoadLibrary(mname)) != NULL) {
@@ -8660,7 +8683,7 @@ void C_ccall dload_2(C_word c, C_word *av0)
}
C_dlerror = (char *) C_strerror(errno);
- C_kontinue(k, C_SCHEME_FALSE);
+ C_kontinue_av(av, k, C_SCHEME_FALSE);
}
#endif
@@ -8706,7 +8729,7 @@ void C_ccall become_2(C_word c, C_word *av)
C_word k = av[ 0 ];
*forwarding_table = 0;
- C_kontinue(k, C_SCHEME_UNDEFINED);
+ C_kontinue_av(av, k, C_SCHEME_UNDEFINED);
}
@@ -8804,16 +8827,16 @@ void C_ccall C_locative_ref(C_word c, C_word *av)
if(ptr == NULL) barf(C_LOST_LOCATIVE_ERROR, "locative-ref", loc);
switch(C_unfix(C_block_item(loc, 2))) {
- case C_SLOT_LOCATIVE: C_kontinue(k, *ptr);
- case C_CHAR_LOCATIVE: C_kontinue(k, C_make_character(*((char *)ptr)));
- case C_U8_LOCATIVE: C_kontinue(k, C_fix(*((unsigned char *)ptr)));
- 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: 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)));
+ case C_SLOT_LOCATIVE: C_kontinue_av(av, k, *ptr);
+ case C_CHAR_LOCATIVE: C_kontinue_av(av, k, C_make_character(*((char *)ptr)));
+ case C_U8_LOCATIVE: C_kontinue_av(av, k, C_fix(*((unsigned char *)ptr)));
+ case C_S8_LOCATIVE: C_kontinue_av(av, k, C_fix(*((char *)ptr)));
+ case C_U16_LOCATIVE: C_kontinue_av(av, k, C_fix(*((unsigned short *)ptr)));
+ case C_S16_LOCATIVE: C_kontinue_av(av, k, C_fix(*((short *)ptr)));
+ case C_U32_LOCATIVE: C_kontinue_av(av, k, C_unsigned_int_to_num(&a, *((C_u32 *)ptr)));
+ case C_S32_LOCATIVE: C_kontinue_av(av, k, C_int_to_num(&a, *((C_s32 *)ptr)));
+ case C_F32_LOCATIVE: C_kontinue_av(av, k, C_flonum(&a, *((float *)ptr)));
+ case C_F64_LOCATIVE: C_kontinue_av(av, k, C_flonum(&a, *((double *)ptr)));
default: panic(C_text("bad locative type"));
}
}
@@ -9022,7 +9045,7 @@ static void C_ccall copy_closure_2(C_word c, C_word *av)
*(p++) = C_CLOSURE_TYPE | cells;
/* this is only allowed because the storage is freshly allocated: */
C_memcpy_slots(p, C_data_pointer(proc), cells);
- C_kontinue(k, (C_word)ptr);
+ C_kontinue(k, (C_word)ptr); // no argv-reuse!
}
@@ -9035,7 +9058,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[ 3 ];
+ *av2 = C_allocate_argvector(c, av, 3);
av2[ 0 ] = C_closure(&a, 1, (C_word)termination_continuation); /* k */
av2[ 1 ] = proc;
@@ -9642,7 +9665,7 @@ static void C_ccall dump_heap_state_2(C_word c, C_word *av)
C_fprintf(C_stderr, C_text("\ntotal number of blocks: %d, immediates: %d\n"),
blk, imm);
C_free(hdump_table);
- C_kontinue(k, C_SCHEME_UNDEFINED);
+ C_kontinue_av(av, k, C_SCHEME_UNDEFINED);
}
@@ -9682,14 +9705,14 @@ static void C_ccall filter_heap_objects_2(C_word c, C_word *av)
++vcount;
}
else {
- C_kontinue(k, C_fix(-1));
+ C_kontinue_av(av, k, C_fix(-1)); // no arg-reuse
}
}
scan = (C_byte *)sbp + C_align(bytes) + sizeof(C_word);
}
- C_kontinue(k, C_fix(vcount));
+ C_kontinue_av(av, k, C_fix(vcount)); // no arg-reuse
}
_______________________________________________
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers
