* incremental step towards loading a fresh compiler for
bootstrapping.
This commit is contained in:
Abdulaziz Ghuloum
parent
18777b192d
commit
6bdb50004a
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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){
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
|
|
|||
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
|
|
@ -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!
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue