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

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

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

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

@ -1007,8 +1007,19 @@
(define assemble-sources
(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*)]
[ls* (map cdr ls*)])
[code-name* (map code-name ls*)]
[ls* (map code-list ls*)])
(let* ([ls* (map convert-instructions ls*)]
[ls* (map optimize-local-jumps ls*)])
(let ([n* (map compute-code-size ls*)]
@ -1024,6 +1035,10 @@
; (printf "RV=~s\n" x))
; 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*)))))))

31
src/libaltcogen.ss
View File

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

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

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