>From 449d3a83fb51c4487f2cd1611465d95a96a7921c Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Sat, 12 Oct 2013 11:12:57 +0200 Subject: [PATCH 1/3] Add paranoid checks to C_u_i_car and C_u_i_cdr. Replace all calls to these two on non-pairs for "convenience" (use C_block_item) --- chicken.h | 17 ++++++++++++++--- runtime.c | 51 +++++++++++++++++++++++++-------------------------- 2 files changed, 39 insertions(+), 29 deletions(-) diff --git a/chicken.h b/chicken.h index 07e4fe8..bbfdfc5 100644 --- a/chicken.h +++ b/chicken.h @@ -1279,7 +1279,7 @@ extern double trunc(double); #define C_pointer_address(x) ((C_byte *)C_block_item((x), 0)) #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_kontinue(k, r) ((C_proc2)(void *)C_u_i_car(k))(2, (k), (r)) +#define C_kontinue(k, r) ((C_proc2)(void *)C_block_item(k,0))(2, (k), (r)) #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) @@ -1385,8 +1385,8 @@ extern double trunc(double); #define C_i_list_ref(lst, i) C_i_car(C_i_list_tail(lst, i)) #define C_u_i_list_ref(lst, i) C_u_i_car(C_i_list_tail(lst, i)) -#define C_u_i_car(x) C_block_item(x, 0) -#define C_u_i_cdr(x) C_block_item(x, 1) +#define C_u_i_car(x) (*C_CHECKp(x,C_pairp(C_VAL1(x)),&C_block_item(C_VAL1(x), 0))) +#define C_u_i_cdr(x) (*C_CHECKp(x,C_pairp(C_VAL1(x)),&C_block_item(C_VAL1(x), 1))) #define C_u_i_caar(x) C_u_i_car( C_u_i_car( x ) ) #define C_u_i_cadr(x) C_u_i_car( C_u_i_cdr( x ) ) #define C_u_i_cdar(x) C_u_i_cdr( C_u_i_car( x ) ) @@ -2672,6 +2672,17 @@ C_inline C_word C_fcall C_a_pair(C_word **ptr, C_word car, C_word cdr) return (C_word)p0; } +C_inline C_word C_fcall C_a_bucket(C_word **ptr, C_word head, C_word tail) +{ + C_word *p = *ptr, *p0 = p; + + *(p++) = C_BUCKET_TYPE | (C_SIZEOF_BUCKET - 1); + *(p++) = head; + *(p++) = tail; + *ptr = p; + return (C_word)p0; +} + C_inline C_word C_a_i_list1(C_word **a, int n, C_word x1) { diff --git a/runtime.c b/runtime.c index ab61a0d..2c622cb 100644 --- a/runtime.c +++ b/runtime.c @@ -906,7 +906,7 @@ void *CHICKEN_global_lookup(char *name) void *root = CHICKEN_new_gc_root(); if(C_truep(s = lookup(key, len, name, symbol_table))) { - if(C_u_i_car(s) != C_SCHEME_UNBOUND) { + if(C_block_item(s, 0) != C_SCHEME_UNBOUND) { CHICKEN_gc_root_set(root, s); return root; } @@ -996,7 +996,7 @@ C_regparm C_word C_find_symbol(C_word str, C_SYMBOL_TABLE *stable) else return C_SCHEME_FALSE; } - +/* OBSOLETE */ C_regparm C_word C_enumerate_symbols(C_SYMBOL_TABLE *stable, C_word pos) { int i; @@ -1554,7 +1554,7 @@ void barf(int code, char *loc, ...) C_dbg_hook(C_SCHEME_UNDEFINED); C_temporary_stack = C_temporary_stack_bottom; - err = C_u_i_car(err); + err = C_block_item(err, 0); if(C_immediatep(err)) panic(C_text("`##sys#error-hook' is not defined - the `library' unit was probably not linked with this executable")); @@ -2013,8 +2013,8 @@ void C_zap_strings(C_word str) for(bucket = symbol_table->table[ i ]; bucket != C_SCHEME_END_OF_LIST; - bucket = C_u_i_cdr(bucket)) { - sym = C_u_i_car(bucket); + bucket = C_block_item(bucket,1)) { + sym = C_block_item(bucket,0); C_set_block_item(sym, 1, str); } } @@ -2171,7 +2171,7 @@ C_regparm C_word C_fcall C_intern3(C_word **ptr, C_char *str, C_word value) { C_word s = C_intern_in(ptr, C_strlen(str), str, symbol_table); - C_mutate2(&C_u_i_car(s), value); + C_mutate2(&C_block_item(s,0), value); return s; } @@ -2194,8 +2194,8 @@ C_regparm C_word C_fcall lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE C_word bucket, sym, s; for(bucket = stable->table[ key ]; bucket != C_SCHEME_END_OF_LIST; - bucket = C_u_i_cdr(bucket)) { - sym = C_u_i_car(bucket); + bucket = C_block_item(bucket,1)) { + sym = C_block_item(bucket,0); s = C_block_item(sym, 1); if(C_header_size(s) == (C_word)len @@ -2216,7 +2216,7 @@ double compute_symbol_table_load(double *avg_bucket_len, int *total_n) bucket = symbol_table->table[ i ]; for(j = 0; bucket != C_SCHEME_END_OF_LIST; ++j) - bucket = C_u_i_cdr(bucket); + bucket = C_block_item(bucket,1); if(j > 0) { alen += j; @@ -2250,8 +2250,7 @@ C_word add_symbol(C_word **ptr, C_word key, C_word string, C_SYMBOL_TABLE *stabl C_set_block_item(sym, 2, C_SCHEME_END_OF_LIST); *ptr = p; b2 = stable->table[ key ]; /* previous bucket */ - bucket = C_a_pair(ptr, sym, b2); /* create new bucket */ - C_block_header(bucket) = (C_block_header(bucket) & ~C_HEADER_TYPE_BITS) | C_BUCKET_TYPE; + bucket = C_a_bucket(ptr, sym, b2); /* create new bucket */ if(ptr != C_heaptop) C_mutate_slot(&stable->table[ key ], bucket); else { @@ -2259,7 +2258,7 @@ C_word add_symbol(C_word **ptr, C_word key, C_word string, C_SYMBOL_TABLE *stabl heap-top (say, in a toplevel literal frame allocation) then we have to inform the memory manager that a 2nd gen. block points to a 1st gen. block, hence the mutation: */ - C_mutate2(&C_u_i_cdr(bucket), b2); + C_mutate2(&C_block_item(bucket,1), b2); stable->table[ key ] = bucket; } @@ -2969,7 +2968,7 @@ C_regparm void C_fcall C_reclaim(void *trampoline, void *proc) C_dbg(C_text("GC"), C_text("queueing %d finalizer(s)\n"), pending_finalizer_count); last = C_block_item(pending_finalizers_symbol, 0); - assert(C_u_i_car(last) == C_fix(0)); + assert(C_block_item(last, 0) == C_fix(0)); C_set_block_item(last, 0, C_fix(pending_finalizer_count)); for(i = 0; i < pending_finalizer_count; ++i) { @@ -3040,10 +3039,10 @@ C_regparm void C_fcall C_reclaim(void *trampoline, void *proc) for(i = 0; i < stp->size; ++i) { last = 0; - for(bucket = stp->table[ i ]; bucket != C_SCHEME_END_OF_LIST; bucket = C_u_i_cdr(bucket)) - if(C_u_i_car(bucket) == C_SCHEME_UNDEFINED) { - if(last) C_set_block_item(last, 1, C_u_i_cdr(bucket)); - else stp->table[ i ] = C_u_i_cdr(bucket); + for(bucket = stp->table[ i ]; bucket != C_SCHEME_END_OF_LIST; bucket = C_block_item(bucket,1)) + if(C_block_item(bucket,0) == C_SCHEME_UNDEFINED) { + if(last) C_set_block_item(last, 1, C_block_item(bucket,1)); + else stp->table[ i ] = C_block_item(bucket,1); } else last = bucket; } @@ -3227,7 +3226,7 @@ C_regparm void C_fcall really_mark(C_word *x) #endif if(C_enable_gcweak && (h & C_HEADER_TYPE_BITS) == C_BUCKET_TYPE) { - item = C_u_i_car(val); + item = C_block_item(val,0); /* Lookup item in weak item table or add entry: */ if((wep = lookup_weak_table_entry(item, (C_word)p2)) != NULL) { @@ -5684,7 +5683,7 @@ C_regparm C_word C_fcall C_i_check_vector_2(C_word x, C_word loc) C_regparm C_word C_fcall C_i_check_structure_2(C_word x, C_word st, C_word loc) { - if(C_immediatep(x) || C_header_bits(x) != C_STRUCTURE_TYPE || C_u_i_car(x) != st) { + if(C_immediatep(x) || C_header_bits(x) != C_STRUCTURE_TYPE || C_block_item(x,0) != st) { error_location = loc; barf(C_BAD_ARGUMENT_TYPE_BAD_STRUCT_ERROR, NULL, x, st); } @@ -6159,13 +6158,13 @@ void C_ccall C_call_cc(C_word c, C_word closure, C_word k, C_word cont) { C_word *a = C_alloc(3), wrapper; - void *pr = (void *)C_u_i_car(cont); + void *pr = (void *)C_block_item(cont,0); if(C_immediatep(cont) || C_header_bits(cont) != C_CLOSURE_TYPE) barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-current-continuation", cont); /* Check for values-continuation: */ - if(C_u_i_car(k) == (C_word)values_continuation) + if(C_block_item(k,0) == (C_word)values_continuation) wrapper = C_closure(&a, 2, (C_word)call_cc_values_wrapper, k); else wrapper = C_closure(&a, 2, (C_word)call_cc_wrapper, k); @@ -6175,7 +6174,7 @@ void C_ccall C_call_cc(C_word c, C_word closure, C_word k, C_word cont) void C_ccall call_cc_wrapper(C_word c, C_word closure, C_word k, C_word result) { - C_word cont = C_u_i_cdr(closure); + C_word cont = C_block_item(closure,1); if(c != 3) C_bad_argc(c, 3); @@ -6186,7 +6185,7 @@ void C_ccall call_cc_wrapper(C_word c, C_word closure, C_word k, C_word result) void C_ccall call_cc_values_wrapper(C_word c, C_word closure, C_word k, ...) { va_list v; - C_word cont = C_u_i_cdr(closure), + C_word cont = C_block_item(closure,1), x1; int n = c; @@ -6305,7 +6304,7 @@ void C_ccall C_u_call_with_values(C_word c, C_word closure, C_word k, C_word thu void C_ccall values_continuation(C_word c, C_word closure, C_word arg0, ...) { - C_word kont = C_u_i_cdr(closure), + C_word kont = C_block_item(closure, 1), k = C_block_item(closure, 2), n = c, *ptr; @@ -8111,8 +8110,8 @@ void C_ccall C_context_switch(C_word c, C_word closure, C_word k, C_word state) C_temporary_stack = C_temporary_stack_bottom - n; C_memcpy(C_temporary_stack, (C_word *)state + 2, n * sizeof(C_word)); - trampoline = (TRAMPOLINE)C_u_i_car(adrs); - trampoline((void *)C_u_i_cdr(adrs)); + trampoline = (TRAMPOLINE)C_block_item(adrs,0); + trampoline((void *)C_block_item(adrs,1)); } -- 1.8.3.4