* transition of symbols to secondary type done.
This commit is contained in:
Abdulaziz Ghuloum
parent
9ded62b5e5
commit
97f59ad1ee
BIN
bin/ikarus
BIN
bin/ikarus
Binary file not shown.
|
|
@ -61,6 +61,7 @@ ik_make_symbol(ikp str, ikp ustr, ikpcb* pcb){
|
||||||
static ikp
|
static ikp
|
||||||
ik_make_symbol(ikp str, ikp ustr, ikpcb* pcb){
|
ik_make_symbol(ikp str, ikp ustr, ikpcb* pcb){
|
||||||
ikp sym = ik_alloc(pcb, symbol_record_size) + record_tag;
|
ikp sym = ik_alloc(pcb, symbol_record_size) + record_tag;
|
||||||
|
ref(sym, -record_tag) = symbol_record_tag;
|
||||||
ref(sym, off_symbol_record_string) = str;
|
ref(sym, off_symbol_record_string) = str;
|
||||||
ref(sym, off_symbol_record_ustring) = ustr;
|
ref(sym, off_symbol_record_ustring) = ustr;
|
||||||
ref(sym, off_symbol_record_value) = unbound_object;
|
ref(sym, off_symbol_record_value) = unbound_object;
|
||||||
|
|
|
||||||
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
|
|
@ -2324,7 +2324,7 @@
|
||||||
(let ([x (make-primcall op (map Expr arg*))])
|
(let ([x (make-primcall op (map Expr arg*))])
|
||||||
(case op
|
(case op
|
||||||
[(cons) (check-const pair-size x)]
|
[(cons) (check-const pair-size x)]
|
||||||
[($make-symbol) (check-const symbol-size x)]
|
[($make-symbol) (check-const symbol-record-size x)]
|
||||||
[($make-tcbucket) (check-const tcbucket-size x)]
|
[($make-tcbucket) (check-const tcbucket-size x)]
|
||||||
[($frame->continuation $code->closure)
|
[($frame->continuation $code->closure)
|
||||||
(check-const
|
(check-const
|
||||||
|
|
@ -2932,19 +2932,28 @@
|
||||||
(define wordsize 4)
|
(define wordsize 4)
|
||||||
(define wordshift 2)
|
(define wordshift 2)
|
||||||
|
|
||||||
(define symbol-mask 7)
|
;(define symbol-mask 7)
|
||||||
(define symbol-tag 2)
|
;(define symbol-tag 2)
|
||||||
(define disp-symbol-string 0)
|
;(define disp-symbol-string 0)
|
||||||
(define disp-symbol-unique-string 4)
|
;(define disp-symbol-unique-string 4)
|
||||||
(define disp-symbol-value 8)
|
;(define disp-symbol-value 8)
|
||||||
(define disp-symbol-plist 12)
|
;(define disp-symbol-plist 12)
|
||||||
(define disp-symbol-system-value 16)
|
;(define disp-symbol-system-value 16)
|
||||||
(define disp-symbol-function 20)
|
;(define disp-symbol-function 20)
|
||||||
(define disp-symbol-error-function 24)
|
;(define disp-symbol-error-function 24)
|
||||||
(define disp-symbol-unused 28)
|
;(define disp-symbol-unused 28)
|
||||||
(define symbol-size 32)
|
;(define symbol-size 32)
|
||||||
|
|
||||||
|
(define symbol-record-tag #x5F)
|
||||||
|
(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 record-tag 5)
|
||||||
|
(define record-mask 7)
|
||||||
|
|
||||||
(define vector-tag 5)
|
(define vector-tag 5)
|
||||||
(define vector-mask 7)
|
(define vector-mask 7)
|
||||||
|
|
@ -3098,7 +3107,7 @@
|
||||||
(unless (symbol? x)
|
(unless (symbol? x)
|
||||||
(error 'primitive-location
|
(error 'primitive-location
|
||||||
"~s is not a valid location for ~s" x op))
|
"~s is not a valid location for ~s" x op))
|
||||||
(mem (fx- disp-symbol-value symbol-tag) (obj x)))]
|
(mem (fx- disp-symbol-record-value record-tag) (obj x)))]
|
||||||
[else
|
[else
|
||||||
(error 'compile "cannot find location of primitive ~s" op)]))
|
(error 'compile "cannot find location of primitive ~s" op)]))
|
||||||
|
|
||||||
|
|
@ -3217,7 +3226,9 @@
|
||||||
[(pair?) (type-pred pair-mask pair-tag rand* Lt Lf ac)]
|
[(pair?) (type-pred pair-mask pair-tag rand* Lt Lf ac)]
|
||||||
[(char?) (type-pred char-mask char-tag rand* Lt Lf ac)]
|
[(char?) (type-pred char-mask char-tag rand* Lt Lf ac)]
|
||||||
[(string?) (type-pred string-mask string-tag rand* Lt Lf ac)]
|
[(string?) (type-pred string-mask string-tag rand* Lt Lf ac)]
|
||||||
[(symbol?) (type-pred symbol-mask symbol-tag rand* Lt Lf ac)]
|
[(symbol?)
|
||||||
|
(indirect-type-pred vector-mask vector-tag #f
|
||||||
|
symbol-record-tag rand* Lt Lf ac)]
|
||||||
[(procedure?) (type-pred closure-mask closure-tag rand* Lt Lf ac)]
|
[(procedure?) (type-pred closure-mask closure-tag rand* Lt Lf ac)]
|
||||||
[(boolean?) (type-pred bool-mask bool-tag rand* Lt Lf ac)]
|
[(boolean?) (type-pred bool-mask bool-tag rand* Lt Lf ac)]
|
||||||
[(null?) (type-pred #f nil rand* Lt Lf ac)]
|
[(null?) (type-pred #f nil rand* Lt Lf ac)]
|
||||||
|
|
@ -3641,11 +3652,11 @@
|
||||||
[($string-length)
|
[($string-length)
|
||||||
(indirect-ref arg* (fx- disp-string-length string-tag) ac)]
|
(indirect-ref arg* (fx- disp-string-length string-tag) ac)]
|
||||||
[($symbol-string)
|
[($symbol-string)
|
||||||
(indirect-ref arg* (fx- disp-symbol-string symbol-tag) ac)]
|
(indirect-ref arg* (fx- disp-symbol-record-string record-tag) ac)]
|
||||||
[($symbol-unique-string)
|
[($symbol-unique-string)
|
||||||
(indirect-ref arg* (fx- disp-symbol-unique-string symbol-tag) ac)]
|
(indirect-ref arg* (fx- disp-symbol-record-ustring record-tag) ac)]
|
||||||
[($symbol-value)
|
[($symbol-value)
|
||||||
(indirect-ref arg* (fx- disp-symbol-value symbol-tag) ac)]
|
(indirect-ref arg* (fx- disp-symbol-record-value record-tag) ac)]
|
||||||
[($tcbucket-key)
|
[($tcbucket-key)
|
||||||
(indirect-ref arg* (fx- disp-tcbucket-key vector-tag) ac)]
|
(indirect-ref arg* (fx- disp-tcbucket-key vector-tag) ac)]
|
||||||
[($tcbucket-val)
|
[($tcbucket-val)
|
||||||
|
|
@ -3673,7 +3684,7 @@
|
||||||
(sall (int fx-shift) eax)
|
(sall (int fx-shift) eax)
|
||||||
ac)]
|
ac)]
|
||||||
[($symbol-plist)
|
[($symbol-plist)
|
||||||
(indirect-ref arg* (fx- disp-symbol-plist symbol-tag) ac)]
|
(indirect-ref arg* (fx- disp-symbol-record-plist record-tag) ac)]
|
||||||
[($record-rtd)
|
[($record-rtd)
|
||||||
(indirect-ref arg* (fx- disp-record-rtd record-ptag) ac)]
|
(indirect-ref arg* (fx- disp-record-rtd record-ptag) ac)]
|
||||||
[($constant-ref)
|
[($constant-ref)
|
||||||
|
|
@ -3716,7 +3727,7 @@
|
||||||
(cond
|
(cond
|
||||||
[(symbol? v)
|
[(symbol? v)
|
||||||
(list*
|
(list*
|
||||||
(movl (mem (fx- disp-symbol-value symbol-tag) (obj v)) eax)
|
(movl (mem (fx- disp-symbol-record-value record-tag) (obj v)) eax)
|
||||||
(movl (obj v) ebx)
|
(movl (obj v) ebx)
|
||||||
(cmpl (int unbound) eax)
|
(cmpl (int unbound) eax)
|
||||||
(je (label (sl-top-level-value-error-label)))
|
(je (label (sl-top-level-value-error-label)))
|
||||||
|
|
@ -3730,10 +3741,13 @@
|
||||||
(NonTail x
|
(NonTail x
|
||||||
(list*
|
(list*
|
||||||
(movl eax ebx)
|
(movl eax ebx)
|
||||||
(andl (int symbol-mask) eax)
|
(andl (int record-mask) eax)
|
||||||
(cmpl (int symbol-tag) eax)
|
(cmpl (int record-tag) eax)
|
||||||
(jne (label (sl-top-level-value-error-label)))
|
(jne (label (sl-top-level-value-error-label)))
|
||||||
(movl (mem (fx- disp-symbol-value symbol-tag) ebx) eax)
|
(movl (mem (- record-tag) ebx) eax)
|
||||||
|
(cmpl (int symbol-record-tag) eax)
|
||||||
|
(jne (label (sl-top-level-value-error-label)))
|
||||||
|
(movl (mem (fx- disp-symbol-record-value record-tag) ebx) eax)
|
||||||
(cmpl (int unbound) eax)
|
(cmpl (int unbound) eax)
|
||||||
(je (label (sl-top-level-value-error-label)))
|
(je (label (sl-top-level-value-error-label)))
|
||||||
ac))]))]
|
ac))]))]
|
||||||
|
|
@ -3847,18 +3861,16 @@
|
||||||
(mem (fx- disp-cdr (fx+ pair-tag pair-size)) apr))
|
(mem (fx- disp-cdr (fx+ pair-tag pair-size)) apr))
|
||||||
(f b (car d) (cdr d)))))))])]
|
(f b (car d) (cdr d)))))))])]
|
||||||
[($make-symbol)
|
[($make-symbol)
|
||||||
(list* (movl (Simple (car arg*)) eax)
|
(list* (movl (int symbol-record-tag) (mem 0 apr))
|
||||||
(movl eax (mem disp-symbol-string apr))
|
(movl (Simple (car arg*)) eax)
|
||||||
(movl (int 0) (mem disp-symbol-unique-string apr))
|
(movl eax (mem disp-symbol-record-string apr))
|
||||||
(movl (int unbound) (mem disp-symbol-value apr))
|
(movl (int 0) (mem disp-symbol-record-ustring apr))
|
||||||
(movl (int nil) (mem disp-symbol-plist apr))
|
(movl (int unbound) (mem disp-symbol-record-value apr))
|
||||||
(movl (int unbound) (mem disp-symbol-system-value apr))
|
(movl (int 0) (mem disp-symbol-record-proc apr))
|
||||||
(movl (int 0) (mem disp-symbol-function apr))
|
(movl (int nil) (mem disp-symbol-record-plist apr))
|
||||||
(movl (int 0) (mem disp-symbol-error-function apr))
|
|
||||||
(movl (int 0) (mem disp-symbol-unused apr))
|
|
||||||
(movl apr eax)
|
(movl apr eax)
|
||||||
(addl (int symbol-tag) eax)
|
(addl (int record-tag) eax)
|
||||||
(addl (int (align symbol-size)) apr)
|
(addl (int (align symbol-record-size)) apr)
|
||||||
ac)]
|
ac)]
|
||||||
[($make-port/input) (do-make-port input-port-tag arg* ac)]
|
[($make-port/input) (do-make-port input-port-tag arg* ac)]
|
||||||
[($make-port/output) (do-make-port output-port-tag arg* ac)]
|
[($make-port/output) (do-make-port output-port-tag arg* ac)]
|
||||||
|
|
@ -4137,11 +4149,9 @@
|
||||||
[($set-symbol-value!)
|
[($set-symbol-value!)
|
||||||
(list* (movl (Simple (car arg*)) eax)
|
(list* (movl (Simple (car arg*)) eax)
|
||||||
(movl (Simple (cadr arg*)) ebx)
|
(movl (Simple (cadr arg*)) ebx)
|
||||||
(movl ebx (mem (fx- disp-symbol-value symbol-tag) eax))
|
(movl ebx (mem (fx- disp-symbol-record-value record-tag) eax))
|
||||||
(movl (mem (fx- disp-symbol-error-function symbol-tag) eax) ebx)
|
|
||||||
(movl ebx (mem (fx- disp-symbol-function symbol-tag) eax))
|
|
||||||
;;; record side effect
|
;;; record side effect
|
||||||
(addl (int (fx- disp-symbol-value symbol-tag)) eax)
|
(addl (int (fx- disp-symbol-record-value record-tag)) eax)
|
||||||
(shrl (int pageshift) eax)
|
(shrl (int pageshift) eax)
|
||||||
(sall (int wordshift) eax)
|
(sall (int wordshift) eax)
|
||||||
(addl (pcb-ref 'dirty-vector) eax)
|
(addl (pcb-ref 'dirty-vector) eax)
|
||||||
|
|
@ -4150,9 +4160,9 @@
|
||||||
[($set-symbol-plist!)
|
[($set-symbol-plist!)
|
||||||
(list* (movl (Simple (car arg*)) eax)
|
(list* (movl (Simple (car arg*)) eax)
|
||||||
(movl (Simple (cadr arg*)) ebx)
|
(movl (Simple (cadr arg*)) ebx)
|
||||||
(movl ebx (mem (fx- disp-symbol-plist symbol-tag) eax))
|
(movl ebx (mem (fx- disp-symbol-record-plist record-tag) eax))
|
||||||
;;; record side effect
|
;;; record side effect
|
||||||
(addl (int (fx- disp-symbol-plist symbol-tag)) eax)
|
(addl (int (fx- disp-symbol-record-plist record-tag)) eax)
|
||||||
(shrl (int pageshift) eax)
|
(shrl (int pageshift) eax)
|
||||||
(sall (int wordshift) eax)
|
(sall (int wordshift) eax)
|
||||||
(addl (pcb-ref 'dirty-vector) eax)
|
(addl (pcb-ref 'dirty-vector) eax)
|
||||||
|
|
@ -4161,9 +4171,9 @@
|
||||||
[($set-symbol-unique-string!)
|
[($set-symbol-unique-string!)
|
||||||
(list* (movl (Simple (car arg*)) eax)
|
(list* (movl (Simple (car arg*)) eax)
|
||||||
(movl (Simple (cadr arg*)) ebx)
|
(movl (Simple (cadr arg*)) ebx)
|
||||||
(movl ebx (mem (fx- disp-symbol-unique-string symbol-tag) eax))
|
(movl ebx (mem (fx- disp-symbol-record-ustring record-tag) eax))
|
||||||
;;; record side effect
|
;;; record side effect
|
||||||
(addl (int (fx- disp-symbol-unique-string symbol-tag)) eax)
|
(addl (int (fx- disp-symbol-record-ustring record-tag)) eax)
|
||||||
(shrl (int pageshift) eax)
|
(shrl (int pageshift) eax)
|
||||||
(sall (int wordshift) eax)
|
(sall (int wordshift) eax)
|
||||||
(addl (pcb-ref 'dirty-vector) eax)
|
(addl (pcb-ref 'dirty-vector) eax)
|
||||||
|
|
@ -4172,9 +4182,9 @@
|
||||||
[($set-symbol-string!)
|
[($set-symbol-string!)
|
||||||
(list* (movl (Simple (car arg*)) eax)
|
(list* (movl (Simple (car arg*)) eax)
|
||||||
(movl (Simple (cadr arg*)) ebx)
|
(movl (Simple (cadr arg*)) ebx)
|
||||||
(movl ebx (mem (fx- disp-symbol-string symbol-tag) eax))
|
(movl ebx (mem (fx- disp-symbol-record-string record-tag) eax))
|
||||||
;;; record side effect
|
;;; record side effect
|
||||||
(addl (int (fx- disp-symbol-string symbol-tag)) eax)
|
(addl (int (fx- disp-symbol-record-string record-tag)) eax)
|
||||||
(shrl (int pageshift) eax)
|
(shrl (int pageshift) eax)
|
||||||
(sall (int wordshift) eax)
|
(sall (int wordshift) eax)
|
||||||
(addl (pcb-ref 'dirty-vector) eax)
|
(addl (pcb-ref 'dirty-vector) eax)
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,205 @@
|
||||||
|
|
||||||
|
(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)])))
|
||||||
|
|
@ -8,7 +8,6 @@
|
||||||
current-primitive-locations
|
current-primitive-locations
|
||||||
compile-core-expr-to-port))
|
compile-core-expr-to-port))
|
||||||
|
|
||||||
;(import (ikarus) (ikarus system $bootstrap))
|
|
||||||
|
|
||||||
(define scheme-library-files
|
(define scheme-library-files
|
||||||
;;; Listed in the order in which they're loaded.
|
;;; Listed in the order in which they're loaded.
|
||||||
|
|
@ -712,46 +711,6 @@
|
||||||
code)))
|
code)))
|
||||||
|
|
||||||
|
|
||||||
;;; (define (install-system-libraries export-subst export-env)
|
|
||||||
;;; (define (install legend-entry)
|
|
||||||
;;; (let ([key (car legend-entry)]
|
|
||||||
;;; [name (cadr legend-entry)]
|
|
||||||
;;; [visible? (caddr legend-entry)])
|
|
||||||
;;; (let ([id (gensym)]
|
|
||||||
;;; [name name]
|
|
||||||
;;; [version '()]
|
|
||||||
;;; [import-libs '()]
|
|
||||||
;;; [visit-libs '()]
|
|
||||||
;;; [invoke-libs '()])
|
|
||||||
;;; (let-values ([(subst env)
|
|
||||||
;;; (if (equal? name '(ikarus system $all))
|
|
||||||
;;; (values export-subst export-env)
|
|
||||||
;;; (values
|
|
||||||
;;; (get-export-subset key export-subst)
|
|
||||||
;;; '()))])
|
|
||||||
;;; (install-library
|
|
||||||
;;; id name version import-libs visit-libs invoke-libs
|
|
||||||
;;; subst env void void visible?)))))
|
|
||||||
;;; (for-each install library-legend))
|
|
||||||
|
|
||||||
; (let ([code `(library (ikarus primlocs)
|
|
||||||
; (export) ;;; must be empty
|
|
||||||
; (import
|
|
||||||
; (only (ikarus library-manager)
|
|
||||||
; install-library)
|
|
||||||
; (only (ikarus.compiler)
|
|
||||||
; current-primitive-locations)
|
|
||||||
; (ikarus))
|
|
||||||
; (current-primitive-locations
|
|
||||||
; (lambda (x)
|
|
||||||
; (cond
|
|
||||||
; [(assq x ',primlocs) => cdr]
|
|
||||||
; [else #f])))
|
|
||||||
; ,@(map build-library library-legend))])
|
|
||||||
; (let-values ([(code empty-subst empty-env)
|
|
||||||
; (boot-library-expand code)])
|
|
||||||
; code)))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -780,21 +739,6 @@
|
||||||
|
|
||||||
(verify-map)
|
(verify-map)
|
||||||
|
|
||||||
;;; (let* ([names (append (map car ikarus-system-macros)
|
|
||||||
;;; (map car ikarus-procedures-map))]
|
|
||||||
;;; [labels (map (lambda (x) (gensym "boot")) names)]
|
|
||||||
;;; [bindings
|
|
||||||
;;; (append (map cadr ikarus-system-macros)
|
|
||||||
;;; (map (lambda (x)
|
|
||||||
;;; (cons 'core-prim (car x)))
|
|
||||||
;;; ikarus-procedures-map))]
|
|
||||||
;;; [subst (map cons names labels)]
|
|
||||||
;;; [env (map cons labels bindings)])
|
|
||||||
;;; (install-system-libraries subst env))
|
|
||||||
;;;
|
|
||||||
;;; (printf "installed base libraries ~s\n"
|
|
||||||
;;; (installed-libraries))
|
|
||||||
|
|
||||||
(time-it "the entire bootstrap process"
|
(time-it "the entire bootstrap process"
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(let-values ([(core* locs)
|
(let-values ([(core* locs)
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue