diff --git a/bin/ikarus b/bin/ikarus index cb0187f..cf97a7c 100755 Binary files a/bin/ikarus and b/bin/ikarus differ diff --git a/bin/ikarus-collect.c b/bin/ikarus-collect.c index 76ec750..0a17bc8 100644 --- a/bin/ikarus-collect.c +++ b/bin/ikarus-collect.c @@ -319,6 +319,7 @@ ik_collect(int mem_req, ikpcb* pcb){ collect_stack(&gc, pcb->frame_pointer, pcb->frame_base - wordsize); pcb->next_k = add_object(&gc, pcb->next_k, "next_k"); pcb->symbol_table = add_object(&gc, pcb->symbol_table, "symbol_table"); + pcb->gensym_table = add_object(&gc, pcb->gensym_table, "gensym_table"); pcb->arg_list = add_object(&gc, pcb->arg_list, "args_list_foo"); /* now we trace all live objects */ collect_loop(&gc); diff --git a/bin/ikarus-fasl.c b/bin/ikarus-fasl.c index 3f55229..8eb2c90 100644 --- a/bin/ikarus-fasl.c +++ b/bin/ikarus-fasl.c @@ -257,7 +257,7 @@ static ikp do_read(ikpcb* pcb, fasl_port* p){ else if(c == 'M'){ /* symbol */ ikp str = do_read(pcb, p); - ikp sym = ik_intern_string(str, pcb); + ikp sym = ikrt_string_to_symbol(str, pcb); if(put_mark_index){ p->marks[put_mark_index] = sym; } diff --git a/bin/ikarus-symbol-table.c b/bin/ikarus-symbol-table.c index 989e040..210e3ab 100644 --- a/bin/ikarus-symbol-table.c +++ b/bin/ikarus-symbol-table.c @@ -5,13 +5,12 @@ #include static ikp -initialize_symbol_table(ikpcb* pcb){ +make_symbol_table(ikpcb* pcb){ #define NUM_OF_BUCKETS 4096 /* power of 2 */ int size = align_to_next_page(disp_vector_data + NUM_OF_BUCKETS * wordsize); ikp st = ik_mmap_ptr(size, 0, pcb) + vector_tag; bzero(st-vector_tag, size); ref(st, off_vector_length) = fix(NUM_OF_BUCKETS); - pcb->symbol_table = st; return st; } @@ -43,10 +42,11 @@ static int strings_eqp(ikp str1, ikp str2){ return 0; } -static ikp ik_make_symbol(ikp str, ikpcb* pcb){ +static ikp +ik_make_symbol(ikp str, ikp ustr, ikpcb* pcb){ ikp sym = ik_alloc(pcb, symbol_size) + symbol_tag; ref(sym, off_symbol_string) = str; - ref(sym, off_symbol_ustring) = false_object; + ref(sym, off_symbol_ustring) = ustr; ref(sym, off_symbol_value) = unbound_object; ref(sym, off_symbol_plist) = null_object; ref(sym, off_symbol_system_value) = str; @@ -55,11 +55,8 @@ static ikp ik_make_symbol(ikp str, ikpcb* pcb){ } -ikp ik_intern_string(ikp str, ikpcb* pcb){ - ikp st = pcb->symbol_table; - if(st == 0){ - st = initialize_symbol_table(pcb); - } +static ikp +intern_string(ikp str, ikp st, ikpcb* pcb){ int h = compute_hash(str); int idx = h & (unfix(ref(st, off_vector_length)) - 1); ikp bckt = ref(st, off_vector_data + idx*wordsize); @@ -72,7 +69,7 @@ ikp ik_intern_string(ikp str, ikpcb* pcb){ } b = ref(b, off_cdr); } - ikp sym = ik_make_symbol(str, pcb); + ikp sym = ik_make_symbol(str, false_object, pcb); b = ik_alloc(pcb, pair_size) + pair_tag; ref(b, off_car) = sym; ref(b, off_cdr) = bckt; @@ -81,6 +78,87 @@ ikp ik_intern_string(ikp str, ikpcb* pcb){ return sym; } +ikp +ikrt_intern_unique_string(ikp ustr, ikp st, ikpcb* pcb){ + int h = compute_hash(ustr); + int idx = h & (unfix(ref(st, off_vector_length)) - 1); + ikp bckt = ref(st, off_vector_data + idx*wordsize); + ikp b = bckt; + while(b){ + ikp sym = ref(b, off_car); + ikp sym_str = ref(sym, off_symbol_ustring); + if(strings_eqp(sym_str, ustr)){ + return sym; + } + b = ref(b, off_cdr); + } + ikp sym = ik_make_symbol(false_object, ustr, pcb); + b = ik_alloc(pcb, pair_size) + pair_tag; + ref(b, off_car) = sym; + ref(b, off_cdr) = bckt; + ref(st, off_vector_data + idx*wordsize) = b; + pcb->dirty_vector[page_index(st+off_vector_data+idx*wordsize)] = -1; + return sym; +} + +ikp +ikrt_intern_gensym(ikp sym, ikpcb* pcb){ + ikp st = pcb->gensym_table; + if(st == 0){ + st = make_symbol_table(pcb); + pcb->gensym_table = st; + } + ikp ustr = ref(sym, off_symbol_ustring); + int h = compute_hash(ustr); + int idx = h & (unfix(ref(st, off_vector_length)) - 1); + ikp bckt = ref(st, off_vector_data + idx*wordsize); + ikp b = bckt; + while(b){ + ikp sym = ref(b, off_car); + ikp sym_ustr = ref(sym, off_symbol_ustring); + if(strings_eqp(sym_ustr, ustr)){ + return false_object; + } + b = ref(b, off_cdr); + } + b = ik_alloc(pcb, pair_size) + pair_tag; + ref(b, off_car) = sym; + ref(b, off_cdr) = bckt; + ref(st, off_vector_data + idx*wordsize) = b; + pcb->dirty_vector[page_index(st+off_vector_data+idx*wordsize)] = -1; + return true_object; +} + + + + +ikp +ikrt_string_to_symbol(ikp str, ikpcb* pcb){ + ikp st = pcb->symbol_table; + if(st == 0){ + st = make_symbol_table(pcb); + pcb->symbol_table = st; + } + return intern_string(str, st, pcb); +} + +ikp +ik_intern_string(ikp str, ikpcb* pcb){ + return ikrt_string_to_symbol(str, pcb); +} + +ikp +ikrt_string_to_gensym(ikp str, ikpcb* pcb){ + ikp st = pcb->gensym_table; + if(st == 0){ + st = make_symbol_table(pcb); + pcb->gensym_table = st; + } + return intern_string(str, st, pcb); +} + + + ikp ik_cstring_to_symbol(char* str, ikpcb* pcb){ int n = strlen(str); @@ -88,6 +166,6 @@ ik_cstring_to_symbol(char* str, ikpcb* pcb){ ikp s = ik_alloc(pcb, align(size)) + string_tag; ref(s, off_string_length) = fix(n); memcpy(s+off_string_data, str, n+1); - ikp sym = ik_intern_string(s, pcb); + ikp sym = ikrt_string_to_symbol(s, pcb); return sym; } diff --git a/bin/ikarus.h b/bin/ikarus.h index 19470c1..6b5742c 100644 --- a/bin/ikarus.h +++ b/bin/ikarus.h @@ -124,7 +124,8 @@ typedef struct ikpcb{ ikpage* uncached_pages; /* ikpages cached so that we don't malloc/free */ ikp stack_base; int stack_size; - ikp symbol_table;; + ikp symbol_table; + ikp gensym_table; ik_guardian_table* guardians[generation_count]; unsigned int* dirty_vector_base; unsigned int* segment_vector_base; @@ -160,7 +161,7 @@ ikp ik_exec_code(ikpcb* pcb, ikp code_ptr); void ik_print(ikp x); void ik_fprint(FILE*, ikp x); -ikp ik_intern_string(ikp, ikpcb*); +ikp ikrt_string_to_symbol(ikp, ikpcb*); ikp ik_cstring_to_symbol(char*, ikpcb*); diff --git a/src/ikarus.boot b/src/ikarus.boot index b653f39..341ef5c 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/libcore.ss b/src/libcore.ss index 3236b4e..ad674f4 100644 --- a/src/libcore.ss +++ b/src/libcore.ss @@ -1074,7 +1074,7 @@ reference-implementation: (lambda (x) (unless (string? x) (error 'string->symbol "~s is not a string" x)) - (foreign-call "ik_intern_string" x))) + (foreign-call "ikrt_string_to_symbol" x))) (primitive-set! 'gensym (case-lambda @@ -1139,39 +1139,6 @@ reference-implementation: (f ($symbol-plist x) '())))) -;;X (primitive-set! 'make-parameter -;;X (letrec ([make-param-no-guard -;;X (lambda (x) -;;X (lambda args -;;X (if (null? args) -;;X x -;;X (if (null? ($cdr args)) -;;X (set! x ($car args)) -;;X (error #f "too many arguments to parameter")))))] -;;X [make-param-with-guard -;;X (lambda (x g) -;;X (let ([f -;;X (lambda args -;;X (if (null? args) -;;X x -;;X (if (null? ($cdr args)) -;;X (set! x (g ($car args))) -;;X (error #f "too many arguments to parameter"))))]) -;;X (if (procedure? g) -;;X (begin (set! x (g x)) f) -;;X (error 'make-parameter "not a procedure ~s" g))))]) -;;X (lambda args -;;X (if (pair? args) -;;X (let ([x ($car args)] [args ($cdr args)]) -;;X (if (null? args) -;;X (make-param-no-guard x) -;;X (let ([g ($car args)]) -;;X (if (null? ($cdr args)) -;;X (make-param-with-guard x g) -;;X (error 'make-parameter "too many arguments"))))) -;;X (error 'make-parameter "insufficient arguments"))))) -;;X - (let () (define vector-loop @@ -1619,9 +1586,12 @@ reference-implementation: [(eq? us #t) (error 'gensym->unique-string "~s is not a gensym" x)] [else - (let ([id (uuid)]) - ($set-symbol-unique-string! x id) - id)])))) + (let f ([x x]) + (let ([id (uuid)]) + ($set-symbol-unique-string! x id) + (cond + [(foreign-call "ikrt_intern_gensym" x) id] + [else (f x)])))])))) (primitive-set! 'gensym-prefix (make-parameter