* transition of symbols to secondary type done.

This commit is contained in:
Abdulaziz Ghuloum 2007-05-15 11:37:43 -04:00
parent 9ded62b5e5
commit 97f59ad1ee
6 changed files with 259 additions and 99 deletions

Binary file not shown.

View File

@ -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;

Binary file not shown.

View File

@ -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)

205
src/ikarus.fasl.write.ss Normal file
View File

@ -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)])))

View File

@ -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)