diff --git a/bin/ikarus-collect.c b/bin/ikarus-collect.c index 5b150d3..fa51400 100644 --- a/bin/ikarus-collect.c +++ b/bin/ikarus-collect.c @@ -149,11 +149,22 @@ gc_alloc_new_ptr(int size, int old_gen, gc_t* gc){ return meta_alloc(size, old_gen, gc, meta_ptrs); } +#if 0 static inline ikp gc_alloc_new_symbol(int old_gen, gc_t* gc){ assert(symbol_size == align(symbol_size)); return meta_alloc(symbol_size, old_gen, gc, meta_symbol); } +#endif + +static inline ikp +gc_alloc_new_symbol_record(int old_gen, gc_t* gc){ + assert(symbol_record_size == align(symbol_record_size)); + return meta_alloc(symbol_record_size, old_gen, gc, meta_symbol); +} + + + static inline ikp gc_alloc_new_pair(int old_gen, gc_t* gc){ @@ -928,6 +939,7 @@ add_object_proc(gc_t* gc, ikp x) add_list(gc, t, gen, x, &y); return y; } +#if 0 else if(tag == symbol_tag){ //ikp y = gc_alloc_new_ptr(align(symbol_size),gen, gc) + symbol_tag; ikp y = gc_alloc_new_symbol(gen, gc) + symbol_tag; @@ -946,6 +958,7 @@ add_object_proc(gc_t* gc, ikp x) #endif return y; } +#endif else if(tag == closure_tag){ int size = disp_closure_data+ (int) ref(fst, disp_code_freevars - disp_code_data); @@ -982,6 +995,18 @@ add_object_proc(gc_t* gc, ikp x) #endif return y; } + else if(fst == symbol_record_tag){ + ikp y = gc_alloc_new_symbol_record(gen, gc) + record_tag; + ref(y, -record_tag) = symbol_record_tag; + ref(y, off_symbol_record_string) = ref(x, off_symbol_record_string); + ref(y, off_symbol_record_ustring) = ref(x, off_symbol_record_ustring); + ref(y, off_symbol_record_value) = ref(x, off_symbol_record_value); + ref(y, off_symbol_record_proc) = ref(x, off_symbol_record_proc); + ref(y, off_symbol_record_plist) = ref(x, off_symbol_record_plist); + ref(x, -record_tag) = forward_ptr; + ref(x, wordsize-record_tag) = y; + return y; + } else if(tagof(fst) == rtd_tag){ /* record */ int size = (int) ref(fst, off_rtd_length); diff --git a/bin/ikarus-data.h b/bin/ikarus-data.h index cf90392..6f6767a 100644 --- a/bin/ikarus-data.h +++ b/bin/ikarus-data.h @@ -107,6 +107,7 @@ #define off_vector_length (disp_vector_length - vector_tag) +#if 0 #define symbol_tag 2 #define disp_symbol_string 0 #define disp_symbol_ustring 4 @@ -125,6 +126,21 @@ #define off_symbol_code (disp_symbol_code - symbol_tag) #define off_symbol_errcode (disp_symbol_errcode - symbol_tag) #define off_symbol_unused (disp_symbol_unused - symbol_tag) +#endif + +#define symbol_record_tag ((ikp) 0x5F) +#define disp_symbol_record_string 4 +#define disp_symbol_record_ustring 8 +#define disp_symbol_record_value 12 +#define disp_symbol_record_proc 16 +#define disp_symbol_record_plist 20 +#define symbol_record_size 24 +#define off_symbol_record_string (disp_symbol_record_string - record_tag) +#define off_symbol_record_ustring (disp_symbol_record_ustring - record_tag) +#define off_symbol_record_value (disp_symbol_record_value - record_tag) +#define off_symbol_record_proc (disp_symbol_record_proc - record_tag) +#define off_symbol_record_plist (disp_symbol_record_plist - record_tag) + #define closure_tag 3 #define closure_mask 7 diff --git a/bin/ikarus-fasl.c b/bin/ikarus-fasl.c index c3436b3..1a7c431 100644 --- a/bin/ikarus-fasl.c +++ b/bin/ikarus-fasl.c @@ -340,7 +340,7 @@ static ikp do_read(ikpcb* pcb, fasl_port* p){ ptr -= pair_size; ref(ptr, off_cdr) = null_object; } - ikp gensym_val = ref(symb, off_symbol_value); + ikp gensym_val = ref(symb, off_symbol_record_value); ikp rtd; if(gensym_val == unbound_object){ rtd = ik_alloc(pcb, align(rtd_size)) + vector_tag; @@ -351,8 +351,8 @@ static ikp do_read(ikpcb* pcb, fasl_port* p){ ref(rtd, off_rtd_fields) = fields; ref(rtd, off_rtd_printer) = false_object; ref(rtd, off_rtd_symbol) = symb; - ref(symb, off_symbol_value) = rtd; - pcb->dirty_vector[page_index(symb+off_symbol_value)] = -1; + ref(symb, off_symbol_record_value) = rtd; + pcb->dirty_vector[page_index(symb+off_symbol_record_value)] = -1; } else { rtd = gensym_val; } diff --git a/bin/ikarus-print.c b/bin/ikarus-print.c index c0a8250..f2ab288 100644 --- a/bin/ikarus-print.c +++ b/bin/ikarus-print.c @@ -54,10 +54,12 @@ print(FILE* fh, ikp x){ else if(IK_CHARP(x)){ fprintf(fh, "%s", char_string[IK_CHAR_VAL(x)]); } +#if 0 else if(tagof(x) == symbol_tag){ ikp str = ref(x, off_symbol_string); fprintf(fh, "%s", str+off_string_data); } +#endif else if(tagof(x) == vector_tag){ ikp len = ref(x, off_vector_length); if(len == 0){ diff --git a/bin/ikarus-symbol-table.c b/bin/ikarus-symbol-table.c index f04ed45..2df3b02 100644 --- a/bin/ikarus-symbol-table.c +++ b/bin/ikarus-symbol-table.c @@ -42,6 +42,7 @@ static int strings_eqp(ikp str1, ikp str2){ return 0; } +#if 0 static ikp ik_make_symbol(ikp str, ikp ustr, ikpcb* pcb){ ikp sym = ik_alloc(pcb, symbol_size) + symbol_tag; @@ -55,6 +56,19 @@ ik_make_symbol(ikp str, ikp ustr, ikpcb* pcb){ ref(sym, off_symbol_unused) = 0; return sym; } +#endif + +static ikp +ik_make_symbol(ikp str, ikp ustr, ikpcb* pcb){ + ikp sym = ik_alloc(pcb, symbol_record_size) + record_tag; + ref(sym, off_symbol_record_string) = str; + ref(sym, off_symbol_record_ustring) = ustr; + ref(sym, off_symbol_record_value) = unbound_object; + ref(sym, off_symbol_record_proc) = str; + ref(sym, off_symbol_record_plist) = null_object; + return sym; +} + static ikp @@ -65,7 +79,7 @@ intern_string(ikp str, ikp st, ikpcb* pcb){ ikp b = bckt; while(b){ ikp sym = ref(b, off_car); - ikp sym_str = ref(sym, off_symbol_string); + ikp sym_str = ref(sym, off_symbol_record_string); if(strings_eqp(sym_str, str)){ return sym; } @@ -88,7 +102,7 @@ intern_unique_string(ikp str, ikp ustr, ikp st, ikpcb* pcb){ ikp b = bckt; while(b){ ikp sym = ref(b, off_car); - ikp sym_ustr = ref(sym, off_symbol_ustring); + ikp sym_ustr = ref(sym, off_symbol_record_ustring); if(strings_eqp(sym_ustr, ustr)){ return sym; } @@ -110,14 +124,14 @@ ikrt_intern_gensym(ikp sym, ikpcb* pcb){ st = make_symbol_table(pcb); pcb->gensym_table = st; } - ikp ustr = ref(sym, off_symbol_ustring); + ikp ustr = ref(sym, off_symbol_record_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); + ikp sym_ustr = ref(sym, off_symbol_record_ustring); if(strings_eqp(sym_ustr, ustr)){ return false_object; } diff --git a/src/ikarus.boot b/src/ikarus.boot index da76783..2ef061e 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/ikarus.code-objects.ss b/src/ikarus.code-objects.ss index 7b5c53a..3ceac12 100644 --- a/src/ikarus.code-objects.ss +++ b/src/ikarus.code-objects.ss @@ -1,5 +1,5 @@ -(library (ikarus code-objects) +(library (ikarus.code-objects) (export make-code code-reloc-vector code-freevars code-size code-ref code-set! set-code-reloc-vector! diff --git a/src/ikarus.compiler.ss b/src/ikarus.compiler.ss index 33d8dbd..c92ef0b 100644 --- a/src/ikarus.compiler.ss +++ b/src/ikarus.compiler.ss @@ -1,5 +1,5 @@ -(library (ikarus compiler) +(library (ikarus.compiler) (export compile-core-expr-to-port assembler-output current-primitive-locations eval-core) (import @@ -8,8 +8,8 @@ (except (ikarus) compile-core-expr-to-port assembler-output current-primitive-locations eval-core) - (ikarus intel-assembler) - (ikarus fasl write)) + (ikarus.intel-assembler) + (ikarus.fasl.write)) @@ -2943,6 +2943,9 @@ (define disp-symbol-error-function 24) (define disp-symbol-unused 28) (define symbol-size 32) + + + (define vector-tag 5) (define vector-mask 7) (define disp-vector-length 0) diff --git a/src/ikarus.fasl.ss b/src/ikarus.fasl.ss index bd30941..0694565 100644 --- a/src/ikarus.fasl.ss +++ b/src/ikarus.fasl.ss @@ -30,217 +30,13 @@ -(library (ikarus fasl write) - (export fasl-write) - (import - (ikarus system $codes) - (ikarus system $records) - (ikarus code-objects) - (except (ikarus) fasl-write)) - - (define write-fixnum - (lambda (x p) - (unless (fixnum? x) (error 'write-fixnum "not a fixnum ~s" x)) - (write-char (integer->char (fxsll (fxlogand x #x3F) 2)) p) - (write-char (integer->char (fxlogand (fxsra x 6) #xFF)) p) - (write-char (integer->char (fxlogand (fxsra x 14) #xFF)) p) - (write-char (integer->char (fxlogand (fxsra x 22) #xFF)) p))) - (define write-int - (lambda (x p) - (unless (fixnum? x) (error 'write-int "not a fixnum ~s" x)) - (write-char (integer->char (fxlogand x #xFF)) p) - (write-char (integer->char (fxlogand (fxsra x 8) #xFF)) p) - (write-char (integer->char (fxlogand (fxsra x 16) #xFF)) p) - (write-char (integer->char (fxlogand (fxsra x 24) #xFF)) p))) - - (define fasl-write-immediate - (lambda (x p) - (cond - [(null? x) (write-char #\N p)] - [(fixnum? x) - (write-char #\I p) - (write-fixnum x p)] - [(char? x) - (write-char #\C p) - (write-char x p)] - [(boolean? x) - (write-char (if x #\T #\F) p)] - [(eof-object? x) (write-char #\E p)] - [(eq? x (void)) (write-char #\U p)] - [else (error 'fasl-write "~s is not a fasl-writable immediate" x)]))) - - (define do-write - (lambda (x p h m) - (cond - [(pair? x) - (write-char #\P p) - (fasl-write-object (cdr x) p h - (fasl-write-object (car x) p h m))] - [(vector? x) - (write-char #\V p) - (write-int (vector-length x) p) - (let f ([x x] [i 0] [n (vector-length x)] [m m]) - (cond - [(fx= i n) m] - [else - (f x (fxadd1 i) n - (fasl-write-object (vector-ref x i) p h m))]))] - [(string? x) - (write-char #\S p) - (write-int (string-length x) p) - (let f ([x x] [i 0] [n (string-length x)]) - (cond - [(fx= i n) m] - [else - (write-char (string-ref x i) p) - (f x (fxadd1 i) n)]))] - [(gensym? x) - (write-char #\G p) - (fasl-write-object (gensym->unique-string x) p h - (fasl-write-object (symbol->string x) p h m))] - [(symbol? x) - (write-char #\M p) - (fasl-write-object (symbol->string x) p h m)] - [(code? x) - (write-char #\x p) - (write-int (code-size x) p) - (write-fixnum (code-freevars x) p) - (let f ([i 0] [n (code-size x)]) - (unless (fx= i n) - (write-char (integer->char (code-ref x i)) p) - (f (fxadd1 i) n))) - (fasl-write-object (code-reloc-vector x) p h m)] - [(record? x) - (let ([rtd (record-type-descriptor x)]) - (cond - [(eq? rtd (base-rtd)) - ;;; rtd record - (write-char #\R p) - (let ([names (record-type-field-names x)] - [m - (fasl-write-object (record-type-symbol x) p h - (fasl-write-object (record-type-name x) p h m))]) - (write-int (length names) p) - (let f ([names names] [m m]) - (cond - [(null? names) m] - [else - (f (cdr names) - (fasl-write-object (car names) p h m))])))] - [else - ;;; non-rtd record - (write-char #\{ p) - (write-int (length (record-type-field-names rtd)) p) - (let f ([names (record-type-field-names rtd)] - [m (fasl-write-object rtd p h m)]) - (cond - [(null? names) m] - [else - (f (cdr names) - (fasl-write-object - ((record-field-accessor rtd (car names)) x) - p h m))]))]))] - [(procedure? x) - (write-char #\Q p) - (fasl-write-object ($closure-code x) p h m)] - [else (error 'fasl-write "~s is not fasl-writable" x)]))) - (define fasl-write-object - (lambda (x p h m) - (cond - [(immediate? x) (fasl-write-immediate x p) m] - [(get-hash-table h x #f) => - (lambda (mark) - (unless (fixnum? mark) - (error 'fasl-write "BUG: invalid mark ~s" mark)) - (cond - [(fx= mark 0) ; singly referenced - (do-write x p h m)] - [(fx> mark 0) ; marked but not written - (put-hash-table! h x (fx- 0 m)) - (write-char #\> p) - (write-int m p) - (do-write x p h (fxadd1 m))] - [else - (write-char #\< p) - (write-int (fx- 0 mark) p) - m]))] - [else (error 'fasl-write "BUG: not in hash table ~s" x)]))) - (define make-graph - (lambda (x h) - (unless (immediate? x) - (cond - [(get-hash-table h x #f) => - (lambda (i) - (put-hash-table! h x (fxadd1 i)))] - [else - (put-hash-table! h x 0) - (cond - [(pair? x) - (make-graph (car x) h) - (make-graph (cdr x) h)] - [(vector? x) - (let f ([x x] [i 0] [n (vector-length x)]) - (unless (fx= i n) - (make-graph (vector-ref x i) h) - (f x (fxadd1 i) n)))] - [(symbol? x) - (make-graph (symbol->string x) h) - (when (gensym? x) (make-graph (gensym->unique-string x) h))] - [(string? x) (void)] - [(code? x) - (make-graph (code-reloc-vector x) h)] - [(record? x) - (when (eq? x (base-rtd)) - (error 'fasl-write "base-rtd is not writable")) - (let ([rtd (record-type-descriptor x)]) - (cond - [(eq? rtd (base-rtd)) - ;;; this is an rtd - (make-graph (record-type-name x) h) - (make-graph (record-type-symbol x) h) - (for-each (lambda (x) (make-graph x h)) - (record-type-field-names x))] - [else - ;;; this is a record - (make-graph rtd h) - (for-each - (lambda (name) - (make-graph ((record-field-accessor rtd name) x) h)) - (record-type-field-names rtd))]))] - [(procedure? x) - (let ([code ($closure-code x)]) - (unless (fxzero? (code-freevars code)) - (error 'fasl-write - "Cannot write a non-thunk procedure; the one given has ~s free vars" - (code-freevars code))) - (make-graph code h))] - [else (error 'fasl-write "~s is not fasl-writable" x)])])))) - (define fasl-write-to-port - (lambda (x port) - (let ([h (make-hash-table)]) - (make-graph x h) - (write-char #\# port) - (write-char #\@ port) - (write-char #\I port) - (write-char #\K port) - (write-char #\0 port) - (write-char #\1 port) - (fasl-write-object x port h 1) - (void)))) - (define fasl-write - (case-lambda - [(x) (fasl-write-to-port x (current-output-port))] - [(x port) - (unless (output-port? port) - (error 'fasl-write "~s is not an output port" port)) - (fasl-write-to-port x port)]))) (library (ikarus fasl read) (export fasl-read) (import (ikarus) - (ikarus code-objects) + (ikarus.code-objects) (ikarus system $codes) (ikarus system $records)) diff --git a/src/ikarus.intel-assembler.ss b/src/ikarus.intel-assembler.ss index fa4231d..5e62710 100644 --- a/src/ikarus.intel-assembler.ss +++ b/src/ikarus.intel-assembler.ss @@ -1,10 +1,10 @@ -(library (ikarus intel-assembler) +(library (ikarus.intel-assembler) (export assemble-sources) (import (ikarus) - (ikarus code-objects) + (ikarus.code-objects) (ikarus system $pairs)) (define fold diff --git a/src/ikarus.syntax.ss b/src/ikarus.syntax.ss index fee3cac..a9296a8 100644 --- a/src/ikarus.syntax.ss +++ b/src/ikarus.syntax.ss @@ -14,7 +14,7 @@ (import (r6rs) (except (ikarus library-manager) installed-libraries) - (only (ikarus compiler) eval-core) + (only (ikarus system $bootstrap) eval-core) (chez modules) (ikarus symbols) (ikarus parameters) diff --git a/src/makefile.ss b/src/makefile.ss index 44255f4..ed6f770 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -1,6 +1,13 @@ #!/usr/bin/env ikarus -b ikarus.boot --r6rs-script -(import (ikarus system $bootstrap) (ikarus)) +;(import +; ;(only (ikarus system $bootstrap) boot-library-expand) +; (ikarus.compiler) +; (ikarus.syntax) +; (except (ikarus) +; assembler-output)) + +(import (ikarus) (ikarus system $bootstrap)) (define scheme-library-files ;;; Listed in the order in which they're loaded. @@ -51,6 +58,7 @@ "ikarus.code-objects.ss" "ikarus.intel-assembler.ss" "ikarus.trace.ss" + "ikarus.fasl.write.ss" "ikarus.fasl.ss" "ikarus.compiler.ss" "ikarus.library-manager.ss" @@ -422,6 +430,7 @@ [compile-core-expr-to-port $boot] [current-primitive-locations $boot] [boot-library-expand $boot] + [eval-core $boot] [$car $pairs] [$cdr $pairs] @@ -673,7 +682,7 @@ (import (only (ikarus library-manager) install-library) - (only (ikarus compiler) + (only (ikarus.compiler) current-primitive-locations) (ikarus)) (current-primitive-locations