conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* compiler and fasl-write and fasl-read now understand code 

annotations
This commit is contained in:
Abdulaziz Ghuloum 2007-10-10 04:41:11 -04:00
parent c3d410d572
commit ca27d8e626
8 changed files with 83 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
bin/ikarus
View File

Binary file not shown.

3
bin/ikarus-fasl.c
View File

@ -276,11 +276,12 @@ static ikp do_read(ikpcb* pcb, fasl_port* p){
ikp freevars; ikp freevars;
fasl_read_buf(p, &code_size, sizeof(int)); fasl_read_buf(p, &code_size, sizeof(int));
fasl_read_buf(p, &freevars, sizeof(ikp)); fasl_read_buf(p, &freevars, sizeof(ikp));
ikp annotation = do_read(pcb, p);
ikp code = alloc_code(align(code_size+disp_code_data), pcb); ikp code = alloc_code(align(code_size+disp_code_data), pcb);
ref(code, 0) = code_tag; ref(code, 0) = code_tag;
ref(code, disp_code_code_size) = fix(code_size); ref(code, disp_code_code_size) = fix(code_size);
ref(code, disp_code_freevars) = freevars; ref(code, disp_code_freevars) = freevars;
ref(code, disp_code_annotation) = false_object; ref(code, disp_code_annotation) = annotation;
fasl_read_buf(p, code+disp_code_data, code_size); fasl_read_buf(p, code+disp_code_data, code_size);
if(put_mark_index){ if(put_mark_index){
p->marks[put_mark_index] = code+vector_tag; p->marks[put_mark_index] = code+vector_tag;

BIN
src/ikarus.boot
View File

Binary file not shown.

90
src/ikarus.compiler.ss
View File

@ -73,7 +73,7 @@
(define-record seq (e0 e1)) (define-record seq (e0 e1))
(define-record case-info (label args proper)) (define-record case-info (label args proper))
(define-record clambda-case (info body)) (define-record clambda-case (info body))
(define-record clambda (label cases free)) (define-record clambda (label cases free name))
(define-record closure (code free*)) (define-record closure (code free*))
(define-record funcall (op rand*)) (define-record funcall (op rand*))
(define-record jmpcall (label op rand*)) (define-record jmpcall (label op rand*))
@ -156,38 +156,38 @@
(error 'recordize "unbound ~s" x))) (error 'recordize "unbound ~s" x)))
(define (lexical x) (define (lexical x)
(getprop x *cookie*)) (getprop x *cookie*))
(define (E x) (define (E x ctxt)
(cond (cond
[(pair? x) [(pair? x)
(case (car x) (case (car x)
[(quote) (make-constant (cadr x))] [(quote) (make-constant (cadr x))]
[(if) [(if)
(make-conditional (make-conditional
(E (cadr x)) (E (cadr x) #f)
(E (caddr x)) (E (caddr x) ctxt)
(E (cadddr x)))] (E (cadddr x) ctxt))]
[(set!) [(set!)
(let ([lhs (cadr x)] [rhs (caddr x)]) (let ([lhs (cadr x)] [rhs (caddr x)])
(cond (cond
[(lexical lhs) => [(lexical lhs) =>
(lambda (lhs) (lambda (var)
(make-assign lhs (E rhs)))] (make-assign var (E rhs lhs)))]
[else [else
(make-funcall (make-primref '$init-symbol-value!) (make-funcall (make-primref '$init-symbol-value!)
(list (make-constant lhs) (list (make-constant lhs)
(E rhs)))]))] (E rhs lhs)))]))]
[(begin) [(begin)
(let f ([a (E (cadr x))] [d (cddr x)]) (let f ([a (cadr x)] [d (cddr x)])
(cond (cond
[(null? d) a] [(null? d) (E a ctxt)]
[else [else
(f (make-seq a (E (car d))) (cdr d))]))] (make-seq (E a #f) (f (car d) (cdr d)))]))]
[(letrec) [(letrec)
(let ([bind* (cadr x)] [body (caddr x)]) (let ([bind* (cadr x)] [body (caddr x)])
(let ([lhs* (map car bind*)] (let ([lhs* (map car bind*)]
[rhs* (map cadr bind*)]) [rhs* (map cadr bind*)])
(let ([nlhs* (gen-fml* lhs*)]) (let ([nlhs* (gen-fml* lhs*)])
(let ([expr (make-recbind nlhs* (map E rhs*) (E body))]) (let ([expr (make-recbind nlhs* (map E rhs* lhs*) (E body ctxt))])
(ungen-fml* lhs*) (ungen-fml* lhs*)
expr))))] expr))))]
[(letrec*) [(letrec*)
@ -195,7 +195,7 @@
(let ([lhs* (map car bind*)] (let ([lhs* (map car bind*)]
[rhs* (map cadr bind*)]) [rhs* (map cadr bind*)])
(let ([nlhs* (gen-fml* lhs*)]) (let ([nlhs* (gen-fml* lhs*)])
(let ([expr (make-rec*bind nlhs* (map E rhs*) (E body))]) (let ([expr (make-rec*bind nlhs* (map E rhs* lhs*) (E body ctxt))])
(ungen-fml* lhs*) (ungen-fml* lhs*)
expr))))] expr))))]
[(case-lambda) [(case-lambda)
@ -204,7 +204,7 @@
(lambda (cls) (lambda (cls)
(let ([fml* (car cls)] [body (cadr cls)]) (let ([fml* (car cls)] [body (cadr cls)])
(let ([nfml* (gen-fml* fml*)]) (let ([nfml* (gen-fml* fml*)])
(let ([body (E body)]) (let ([body (E body #f)])
(ungen-fml* fml*) (ungen-fml* fml*)
(make-clambda-case (make-clambda-case
(make-case-info (make-case-info
@ -213,35 +213,25 @@
(list? fml*)) (list? fml*))
body))))) body)))))
(cdr x))]) (cdr x))])
(make-clambda (gensym) cls* #f))] (make-clambda (gensym) cls* #f ctxt))]
[(foreign-call) [(foreign-call)
(let ([name (quoted-string (cadr x))] [arg* (cddr x)]) (let ([name (quoted-string (cadr x))] [arg* (cddr x)])
(make-forcall name (map E arg*)))] (make-forcall name (map (lambda (x) (E x #f)) arg*)))]
[(|#primitive|)
(let ([var (cadr x)])
(make-primref var))]
[(primitive) [(primitive)
(let ([var (cadr x)]) (let ([var (cadr x)])
(make-primref var))] (make-primref var))]
[(top-level-value)
(let ([var (quoted-sym (cadr x))])
(make-funcall
(make-primref 'top-level-value)
(list (make-constant var))))]
[(set-top-level-value!)
(make-funcall (make-primref 'set-top-level-value!)
(map E (cdr x)))]
[(void)
(make-constant (void))]
[else [else
(make-funcall (E (car x)) (map E (cdr x)))])] ;;; should annotate expanded let.
(make-funcall
(E (car x) #f)
(map (lambda (x) (E x #f)) (cdr x)))])]
[(symbol? x) [(symbol? x)
(or (lexical x) (or (lexical x)
(make-funcall (make-funcall
(make-primref 'top-level-value) (make-primref 'top-level-value)
(list (make-constant x))))] (list (make-constant x))))]
[else (error 'recordize "invalid expression ~s" x)])) [else (error 'recordize "invalid expression ~s" x)]))
(E x)) (E x #f))
(define (unparse x) (define (unparse x)
(define (E-args proper x) (define (E-args proper x)
@ -448,14 +438,14 @@
(Expr altern))] (Expr altern))]
[(seq e0 e1) [(seq e0 e1)
(make-seq (Expr e0) (Expr e1))] (make-seq (Expr e0) (Expr e1))]
[(clambda g cls*) [(clambda g cls* free name)
(make-clambda g (make-clambda g
(map (lambda (x) (map (lambda (x)
(record-case x (record-case x
[(clambda-case info body) [(clambda-case info body)
(make-clambda-case info (Expr body))])) (make-clambda-case info (Expr body))]))
cls*) cls*)
#f)] free name)]
[(funcall rator rand*) [(funcall rator rand*)
(inline (Expr rator) (map Expr rand*))] (inline (Expr rator) (map Expr rand*))]
[(forcall rator rand*) [(forcall rator rand*)
@ -596,7 +586,7 @@
[(conditional e0 e1 e2) [(conditional e0 e1 e2)
(make-conditional (E e0 ref comp) (E e1 ref comp) (E e2 ref comp))] (make-conditional (E e0 ref comp) (E e1 ref comp) (E e2 ref comp))]
[(seq e0 e1) (make-seq (E e0 ref comp) (E e1 ref comp))] [(seq e0 e1) (make-seq (E e0 ref comp) (E e1 ref comp))]
[(clambda g cls*) [(clambda g cls* free name)
(make-clambda g (make-clambda g
(map (lambda (x) (map (lambda (x)
(record-case x (record-case x
@ -605,7 +595,7 @@
(let ([body (E body (extend-hash (case-info-args info) h ref) void)]) (let ([body (E body (extend-hash (case-info-args info) h ref) void)])
(make-clambda-case info body)))])) (make-clambda-case info body)))]))
cls*) cls*)
#f)] free name)]
[(funcall rator rand*) [(funcall rator rand*)
(let ([rator (E rator ref comp)] [rand* (E* rand* ref comp)]) (let ([rator (E rator ref comp)] [rand* (E* rand* ref comp)])
(record-case rator (record-case rator
@ -1131,14 +1121,14 @@
(make-seq (make-seq e0 (seq-e0 e1)) (seq-e1 e1))] (make-seq (make-seq e0 (seq-e0 e1)) (seq-e1 e1))]
[else [else
(make-seq e0 e1)])) (make-seq e0 e1)]))
(define (do-clambda g cls*) (define (do-clambda g cls* free name)
(make-clambda g (make-clambda g
(map (lambda (cls) (map (lambda (cls)
(record-case cls (record-case cls
[(clambda-case info body) [(clambda-case info body)
(make-clambda-case info (Value body))])) (make-clambda-case info (Value body))]))
cls*) cls*)
#f)) free name))
(define (Effect x) (define (Effect x)
(record-case x (record-case x
[(constant) the-void] [(constant) the-void]
@ -1267,7 +1257,7 @@
(make-conditional e0 e1 e2))] (make-conditional e0 e1 e2))]
[else (make-conditional e0 e1 e2)])))]))] [else (make-conditional e0 e1 e2)])))]))]
[(seq e0 e1) (mk-seq (Effect e0) (Value e1))] [(seq e0 e1) (mk-seq (Effect e0) (Value e1))]
[(clambda g cls*) (do-clambda g cls*)] [(clambda g cls* free name) (do-clambda g cls* free name)]
[(primcall rator rand*) [(primcall rator rand*)
(optimize-primcall 'v rator (map Value rand*))] (optimize-primcall 'v rator (map Value rand*))]
[(funcall rator rand*) [(funcall rator rand*)
@ -1334,7 +1324,7 @@
[(conditional test conseq altern) [(conditional test conseq altern)
(make-conditional (Expr test) (Expr conseq) (Expr altern))] (make-conditional (Expr test) (Expr conseq) (Expr altern))]
[(seq e0 e1) (make-seq (Expr e0) (Expr e1))] [(seq e0 e1) (make-seq (Expr e0) (Expr e1))]
[(clambda g cls*) [(clambda g cls* free name)
(make-clambda g (make-clambda g
(map (lambda (cls) (map (lambda (cls)
(record-case cls (record-case cls
@ -1346,7 +1336,7 @@
(make-case-info label fml* proper) (make-case-info label fml* proper)
(bind-assigned a-lhs* a-rhs* (Expr body))))])])) (bind-assigned a-lhs* a-rhs* (Expr body))))])]))
cls*) cls*)
#f)] free name)]
[(forcall op rand*) [(forcall op rand*)
(make-forcall op (map Expr rand*))] (make-forcall op (map Expr rand*))]
[(funcall rator rand*) [(funcall rator rand*)
@ -1422,7 +1412,7 @@
[(conditional test conseq altern) [(conditional test conseq altern)
(make-conditional (Expr test) (Expr conseq) (Expr altern))] (make-conditional (Expr test) (Expr conseq) (Expr altern))]
[(seq e0 e1) (make-seq (Expr e0) (Expr e1))] [(seq e0 e1) (make-seq (Expr e0) (Expr e1))]
[(clambda g cls*) [(clambda g cls* free name)
(make-clambda g (make-clambda g
(map (lambda (cls) (map (lambda (cls)
(record-case cls (record-case cls
@ -1430,7 +1420,7 @@
(for-each init-var (case-info-args info)) (for-each init-var (case-info-args info))
(make-clambda-case info (Expr body))])) (make-clambda-case info (Expr body))]))
cls*) cls*)
#f)] free name)]
[(forcall op rand*) [(forcall op rand*)
(make-forcall op (map Expr rand*))] (make-forcall op (map Expr rand*))]
[(funcall rator rand*) [(funcall rator rand*)
@ -1471,7 +1461,7 @@
(values (cons a d) (union a-free d-free)))])) (values (cons a d) (union a-free d-free)))]))
(define (do-clambda x) (define (do-clambda x)
(record-case x (record-case x
[(clambda g cls*) [(clambda g cls* _free name)
(let-values ([(cls* free) (let-values ([(cls* free)
(let f ([cls* cls*]) (let f ([cls* cls*])
(cond (cond
@ -1485,7 +1475,7 @@
(cons (make-clambda-case info body) cls*) (cons (make-clambda-case info body) cls*)
(union (difference body-free (case-info-args info)) (union (difference body-free (case-info-args info))
cls*-free)))])]))]) cls*-free)))])]))])
(values (make-closure (make-clambda g cls* free) free) (values (make-closure (make-clambda g cls* free name) free)
free))])) free))]))
(define (Expr ex) (define (Expr ex)
(record-case ex (record-case ex
@ -1566,7 +1556,7 @@
[else #f])) [else #f]))
(define (trim/lift-code code free*) (define (trim/lift-code code free*)
(record-case code (record-case code
[(clambda label cls* free*/dropped) [(clambda label cls* free*/dropped name)
(let ([cls* (map (let ([cls* (map
(lambda (x) (lambda (x)
(record-case x (record-case x
@ -1577,7 +1567,7 @@
cls*)]) cls*)])
(let ([g (make-code-loc label)]) (let ([g (make-code-loc label)])
(set! all-codes (set! all-codes
(cons (make-clambda label cls* free*) all-codes)) (cons (make-clambda label cls* free* name) all-codes))
g))])) g))]))
(define (optimize-one-closure code free) (define (optimize-one-closure code free)
(let ([free (trim-vars free)]) (let ([free (trim-vars free)])
@ -1680,7 +1670,7 @@
[(jmpcall label rator rand*) (make-jmpcall label (E rator) (map E rand*))] [(jmpcall label rator rand*) (make-jmpcall label (E rator) (map E rand*))]
[(mvcall p c) [(mvcall p c)
(record-case c (record-case c
[(clambda label cases free) [(clambda label cases free name)
(make-mvcall (E p) (make-mvcall (E p)
(make-clambda label (make-clambda label
(map (lambda (x) (map (lambda (x)
@ -1688,7 +1678,7 @@
[(clambda-case info body) [(clambda-case info body)
(make-clambda-case info (E body))])) (make-clambda-case info (E body))]))
cases) cases)
free))])] free name))])]
[else (error who "invalid expression ~s" (unparse x))])) [else (error who "invalid expression ~s" (unparse x))]))
(let ([x (E x)]) (let ([x (E x)])
(make-codes all-codes x))) (make-codes all-codes x)))
@ -1709,8 +1699,8 @@
(make-clambda-case info (Tail body))])) (make-clambda-case info (Tail body))]))
(define (CodeExpr x) (define (CodeExpr x)
(record-case x (record-case x
[(clambda L cases free) [(clambda L cases free name)
(make-clambda L (map CaseExpr cases) free)])) (make-clambda L (map CaseExpr cases) free name)]))
(define (CodesExpr x) (define (CodesExpr x)
(record-case x (record-case x
[(codes list body) [(codes list body)

4
src/ikarus.fasl.write.ss
View File

@ -133,11 +133,12 @@
(write-char #\x p) (write-char #\x p)
(write-int (code-size x) p) (write-int (code-size x) p)
(write-fixnum (code-freevars x) p) (write-fixnum (code-freevars x) p)
(let ([m (fasl-write-object ($code-annotation x) p h m)])
(let f ([i 0] [n (code-size x)]) (let f ([i 0] [n (code-size x)])
(unless (fx= i n) (unless (fx= i n)
(write-byte (code-ref x i) p) (write-byte (code-ref x i) p)
(f (fxadd1 i) n))) (f (fxadd1 i) n)))
(fasl-write-object (code-reloc-vector x) p h m)] (fasl-write-object (code-reloc-vector x) p h m))]
[(record? x) [(record? x)
(let ([rtd (record-type-descriptor x)]) (let ([rtd (record-type-descriptor x)])
(cond (cond
@ -250,6 +251,7 @@
(when (gensym? x) (make-graph (gensym->unique-string x) h))] (when (gensym? x) (make-graph (gensym->unique-string x) h))]
[(string? x) (void)] [(string? x) (void)]
[(code? x) [(code? x)
(make-graph ($code-annotation x) h)
(make-graph (code-reloc-vector x) h)] (make-graph (code-reloc-vector x) h)]
[(record? x) [(record? x)
(when (eq? x (base-rtd)) (when (eq? x (base-rtd))

17
src/ikarus.intel-assembler.ss
View File

@ -1007,8 +1007,19 @@
(define assemble-sources (define assemble-sources
(lambda (thunk?-label ls*) (lambda (thunk?-label ls*)
(define (code-list ls)
(if (let ([a (cadr ls)])
(and (pair? a) (eq? (car a) 'name)))
(cddr ls)
(cdr ls)))
(define (code-name ls)
(let ([a (cadr ls)])
(and (pair? a)
(eq? (car a) 'name))
(cadr a)))
(let ([closure-size* (map car ls*)] (let ([closure-size* (map car ls*)]
[ls* (map cdr ls*)]) [code-name* (map code-name ls*)]
[ls* (map code-list ls*)])
(let* ([ls* (map convert-instructions ls*)] (let* ([ls* (map convert-instructions ls*)]
[ls* (map optimize-local-jumps ls*)]) [ls* (map optimize-local-jumps ls*)])
(let ([n* (map compute-code-size ls*)] (let ([n* (map compute-code-size ls*)]
@ -1024,6 +1035,10 @@
; (printf "RV=~s\n" x)) ; (printf "RV=~s\n" x))
; relv*) ; relv*)
(for-each set-code-reloc-vector! code* relv*) (for-each set-code-reloc-vector! code* relv*)
(for-each (lambda (code name)
(when name
(set-code-annotation! code name)))
code* code-name*)
code*))))))) code*)))))))

31
src/libaltcogen.ss
View File

@ -91,8 +91,8 @@
;;; ;;;
(define (Clambda x) (define (Clambda x)
(record-case x (record-case x
[(clambda label case* free*) [(clambda label case* free* name)
(make-clambda label (map ClambdaCase case*) free*)] (make-clambda label (map ClambdaCase case*) free* name)]
[else (error who "invalid clambda ~s" x)])) [else (error who "invalid clambda ~s" x)]))
;;; ;;;
(define (Program x) (define (Program x)
@ -167,9 +167,9 @@
;;; ;;;
(define (Clambda x) (define (Clambda x)
(record-case x (record-case x
[(clambda label case* free*) [(clambda label case* free* name)
(make-clambda label (map (ClambdaCase free*) case*) (make-clambda label (map (ClambdaCase free*) case*)
free*)] free* name)]
[else (error who "invalid clambda ~s" x)])) [else (error who "invalid clambda ~s" x)]))
;;; ;;;
(define (Program x) (define (Program x)
@ -204,8 +204,8 @@
(make-clambda-case info (Tail body))])) (make-clambda-case info (Tail body))]))
(define (CodeExpr x) (define (CodeExpr x)
(record-case x (record-case x
[(clambda L cases free) [(clambda L cases free name)
(make-clambda L (map CaseExpr cases) free)])) (make-clambda L (map CaseExpr cases) free name)]))
(define (CodesExpr x) (define (CodesExpr x)
(record-case x (record-case x
[(codes list body) [(codes list body)
@ -235,8 +235,8 @@
;;; ;;;
(define (Clambda x) (define (Clambda x)
(record-case x (record-case x
[(clambda label case* free*) [(clambda label case* free* name)
(make-clambda label (map ClambdaCase case*) free*)])) (make-clambda label (map ClambdaCase case*) free* name)]))
;;; ;;;
(define (Main x) (define (Main x)
(if (Tail x) (if (Tail x)
@ -682,8 +682,8 @@
;;; ;;;
(define (Clambda x) (define (Clambda x)
(record-case x (record-case x
[(clambda label case* free*) [(clambda label case* free* name)
(make-clambda label (map ClambdaCase case*) free*)])) (make-clambda label (map ClambdaCase case*) free* name)]))
;;; ;;;
(define (Main x) (define (Main x)
(set! locals '()) (set! locals '())
@ -1815,8 +1815,8 @@
;;; ;;;
(define (Clambda x) (define (Clambda x)
(record-case x (record-case x
[(clambda label case* free*) [(clambda label case* free* name)
(make-clambda label (map ClambdaCase case*) free*)])) (make-clambda label (map ClambdaCase case*) free* name)]))
;;; ;;;
(define (Program x) (define (Program x)
(record-case x (record-case x
@ -2322,8 +2322,8 @@
;;; ;;;
(define (Clambda x) (define (Clambda x)
(record-case x (record-case x
[(clambda label case* free*) [(clambda label case* free* name)
(make-clambda label (map ClambdaCase case*) free*)])) (make-clambda label (map ClambdaCase case*) free* name)]))
;;; ;;;
(define (Program x) (define (Program x)
(record-case x (record-case x
@ -2778,8 +2778,9 @@
;;; ;;;
(define (Clambda x) (define (Clambda x)
(record-case x (record-case x
[(clambda L case* free*) [(clambda L case* free* name)
(cons* (length free*) (cons* (length free*)
`(name ,name)
(label L) (label L)
(let ([ac (list '(nop))]) (let ([ac (list '(nop))])
(parameterize ([exceptions-conc ac]) (parameterize ([exceptions-conc ac])

4
src/pass-specify-rep.ss
View File

@ -462,10 +462,10 @@
;;; ;;;
(define (Clambda x) (define (Clambda x)
(record-case x (record-case x
[(clambda label case* free*) [(clambda label case* free* name)
(make-clambda label (make-clambda label
(map ClambdaCase case*) (map ClambdaCase case*)
free*)] free* name)]
[else (error 'specify-rep "invalid clambda ~s" x)])) [else (error 'specify-rep "invalid clambda ~s" x)]))
;;; ;;;
(define (Program x) (define (Program x)