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

added a label field to clambda record type

This commit is contained in:
Abdulaziz Ghuloum 2006-12-04 19:00:43 -05:00
parent 95ffbd6551
commit 307b166f38
2 changed files with 35 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
lib/ikarus.boot
View File

Binary file not shown.

66
lib/libcompile.ss
View File

@ -1,4 +1,5 @@
;;; 9.0: * calls (gensym <symbol>) instead of ;;; 9.0: * calls (gensym <symbol>) instead of
;;; (gensym (symbol->string <symbol>)) in order to avoid incrementing ;;; (gensym (symbol->string <symbol>)) in order to avoid incrementing
;;; gensym-count. ;;; gensym-count.
@ -231,7 +232,7 @@
(define-record seq (e0 e1)) (define-record seq (e0 e1))
(define-record clambda-case (arg* proper body)) (define-record clambda-case (arg* proper body))
(define-record clambda (cases)) (define-record clambda (label cases))
(define-record clambda-code (label cases free)) (define-record clambda-code (label cases free))
(define-record closure (code free*)) (define-record closure (code free*))
(define-record funcall (op rand*)) (define-record funcall (op rand*))
@ -243,10 +244,6 @@
(define (unique-var x) (define (unique-var x)
(make-var (gensym x) #f #f)) (make-var (gensym x) #f #f))
(define (make-bind^ lhs* rhs* body)
(if (null? lhs*)
body
(make-bind lhs* rhs* body)))
(define (recordize x) (define (recordize x)
(define (gen-fml* fml*) (define (gen-fml* fml*)
@ -355,7 +352,7 @@
(list? fml*) (list? fml*)
body))))) body)))))
(cdr x))]) (cdr x))])
(make-clambda cls*))] (make-clambda (gensym) cls*))]
[(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 (make-forcall name
@ -438,7 +435,7 @@
[(seq e0 e1) `(begin ,(E e0) ,(E e1))] [(seq e0 e1) `(begin ,(E e0) ,(E e1))]
[(clambda-case args proper body) [(clambda-case args proper body)
`(clambda-case ,(E-args proper args) ,(E body))] `(clambda-case ,(E-args proper args) ,(E body))]
[(clambda cls*) [(clambda g cls*)
`(case-lambda . ,(map E cls*))] `(case-lambda . ,(map E cls*))]
[(clambda-code label clauses free) [(clambda-code label clauses free)
`(code ,label . ,(map E clauses))] `(code ,label . ,(map E clauses))]
@ -503,9 +500,9 @@
[else (try-inline (cdr cls*) rand* default)])) [else (try-inline (cdr cls*) rand* default)]))
(define (inline rator rand*) (define (inline rator rand*)
(record-case rator (record-case rator
[(clambda cls*) [(clambda g cls*)
(try-inline cls* rand* (try-inline cls* rand*
(make-funcall rator rand*))] (make-funcall rator rand*))]
[else (make-funcall rator rand*)])) [else (make-funcall rator rand*)]))
(define (Expr x) (define (Expr x)
(record-case x (record-case x
@ -523,8 +520,8 @@
(Expr altern))] (Expr altern))]
[(seq e0 e1) [(seq e0 e1)
(make-seq (Expr e0) (Expr e1))] (make-seq (Expr e0) (Expr e1))]
[(clambda cls*) [(clambda g cls*)
(make-clambda (make-clambda g
(map (lambda (x) (map (lambda (x)
(record-case x (record-case x
[(clambda-case fml* proper body) [(clambda-case fml* proper body)
@ -568,7 +565,7 @@
[(clambda-case fml* proper body) [(clambda-case fml* proper body)
(bt? body)])) (bt? body)]))
(record-case x (record-case x
[(clambda cls*) [(clambda g cls*)
(ormap branching-clause? cls*)] (ormap branching-clause? cls*)]
[else #f])) [else #f]))
(define (analyze producer consumer) (define (analyze producer consumer)
@ -600,7 +597,7 @@
(E conseq) (E conseq)
(E altern)] (E altern)]
[(seq e0 e1) (E e0) (E e1)] [(seq e0 e1) (E e0) (E e1)]
[(clambda cls*) [(clambda g cls*)
(for-each (for-each
(lambda (x) (lambda (x)
(record-case x (record-case x
@ -720,8 +717,8 @@
[(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 cls*) [(clambda g cls*)
(make-clambda (make-clambda g
(map (lambda (x) (map (lambda (x)
(record-case x (record-case x
[(clambda-case fml* proper body) [(clambda-case fml* proper body)
@ -790,8 +787,8 @@
(Expr altern))] (Expr altern))]
[(seq e0 e1) [(seq e0 e1)
(make-seq (Expr e0) (Expr e1))] (make-seq (Expr e0) (Expr e1))]
[(clambda cls*) [(clambda g cls*)
(make-clambda (make-clambda g
(map (lambda (x) (map (lambda (x)
(record-case x (record-case x
[(clambda-case fml* proper body) [(clambda-case fml* proper body)
@ -834,7 +831,7 @@
[(conditional test conseq altern) [(conditional test conseq altern)
(begin (Expr test) (Expr conseq) (Expr altern))] (begin (Expr test) (Expr conseq) (Expr altern))]
[(seq e0 e1) (begin (Expr e0) (Expr e1))] [(seq e0 e1) (begin (Expr e0) (Expr e1))]
[(clambda cls*) [(clambda g cls*)
(for-each (for-each
(lambda (cls) (lambda (cls)
(for-each init-var (clambda-case-arg* cls)) (for-each init-var (clambda-case-arg* cls))
@ -918,14 +915,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 x) (define (do-clambda g cls*)
(make-clambda (make-clambda g
(map (lambda (cls) (map (lambda (cls)
(record-case cls (record-case cls
[(clambda-case arg* proper body) [(clambda-case arg* proper body)
(make-clambda-case arg* proper (make-clambda-case arg* proper
(Value body))])) (Value body))]))
(clambda-cases x)))) cls*)))
(define (Effect x) (define (Effect x)
(record-case x (record-case x
[(constant) the-void] [(constant) the-void]
@ -938,7 +935,7 @@
[(conditional test conseq altern) [(conditional test conseq altern)
(make-conditional (Pred test) (Effect conseq) (Effect altern))] (make-conditional (Pred test) (Effect conseq) (Effect altern))]
[(seq e0 e1) (mk-seq (Effect e0) (Effect e1))] [(seq e0 e1) (mk-seq (Effect e0) (Effect e1))]
[(clambda cls*) the-void] [(clambda g cls*) the-void]
[(primcall rator rand*) ; remove effect-free primcalls [(primcall rator rand*) ; remove effect-free primcalls
(make-primcall rator (map Value rand*))] (make-primcall rator (map Value rand*))]
[(funcall rator rand*) [(funcall rator rand*)
@ -968,7 +965,7 @@
[(conditional test conseq altern) [(conditional test conseq altern)
(make-conditional (Pred test) (Pred conseq) (Pred altern))] (make-conditional (Pred test) (Pred conseq) (Pred altern))]
[(seq e0 e1) (mk-seq (Effect e0) (Pred e1))] [(seq e0 e1) (mk-seq (Effect e0) (Pred e1))]
[(clambda cls*) (make-constant #t)] [(clambda g cls*) (make-constant #t)]
[(primcall rator rand*) ;;; check for some effect-free/known prims [(primcall rator rand*) ;;; check for some effect-free/known prims
(make-primcall rator (map Value rand*))] (make-primcall rator (map Value rand*))]
[(funcall rator rand*) [(funcall rator rand*)
@ -997,7 +994,7 @@
[(conditional test conseq altern) [(conditional test conseq altern)
(make-conditional (Pred test) (Value conseq) (Value altern))] (make-conditional (Pred test) (Value conseq) (Value altern))]
[(seq e0 e1) (mk-seq (Effect e0) (Value e1))] [(seq e0 e1) (mk-seq (Effect e0) (Value e1))]
[(clambda) (do-clambda x)] [(clambda g cls*) (do-clambda g cls*)]
[(primcall rator rand*) [(primcall rator rand*)
(make-primcall rator (map Value rand*))] (make-primcall rator (map Value rand*))]
[(funcall rator rand*) [(funcall rator rand*)
@ -1053,8 +1050,8 @@
[(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 cls*) [(clambda g cls*)
(make-clambda (make-clambda g
(map (lambda (cls) (map (lambda (cls)
(record-case cls (record-case cls
[(clambda-case fml* proper body) [(clambda-case fml* proper body)
@ -1095,7 +1092,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 cls*) [(clambda g cls*)
(let-values ([(cls* free) (let-values ([(cls* free)
(let f ([cls* cls*]) (let f ([cls* cls*])
(cond (cond
@ -1110,7 +1107,7 @@
cls*) cls*)
(union (difference body-free fml*) (union (difference body-free fml*)
cls*-free)))])]))]) cls*-free)))])]))])
(values (make-closure (make-clambda-code (gensym) cls* free) free) (values (make-closure (make-clambda-code g cls* free) free)
free))])) free))]))
(define (Expr ex) (define (Expr ex)
(record-case ex (record-case ex
@ -1458,8 +1455,6 @@
(define (introduce-primcalls x) (define (introduce-primcalls x)
(define who 'introduce-primcalls) (define who 'introduce-primcalls)
(define (simple? x)
(or (constant? x) (var? x) (primref? x)))
(define (Expr x) (define (Expr x)
(record-case x (record-case x
[(constant) x] [(constant) x]
@ -1549,7 +1544,8 @@
(define (simplify-operands x) (define (simplify-operands x)
(define who 'simplify-operands) (define who 'simplify-operands)
(define (simple? x) (define (simple? x)
(or (constant? x) (var? x) (primref? x))) (or (constant? x) (var? x) (primref? x)
(and (closure? x) (null? (closure-free* x)))))
(define (simplify arg lhs* rhs* k) (define (simplify arg lhs* rhs* k)
(if (simple? arg) (if (simple? arg)
(k arg lhs* rhs*) (k arg lhs* rhs*)
@ -1564,6 +1560,10 @@
(simplify* (cdr arg*) lhs* rhs* (simplify* (cdr arg*) lhs* rhs*
(lambda (d lhs* rhs*) (lambda (d lhs* rhs*)
(k (cons a d) lhs* rhs*)))))])) (k (cons a d) lhs* rhs*)))))]))
(define (make-bind^ lhs* rhs* body)
(if (null? lhs*)
body
(make-bind lhs* rhs* body)))
(define (Expr x) (define (Expr x)
(record-case x (record-case x
[(constant) x] [(constant) x]
@ -3331,6 +3331,10 @@
[(constant c) (constant-val c)] [(constant c) (constant-val c)]
[(code-loc label) (label-address label)] [(code-loc label) (label-address label)]
[(primref op) (primref-loc op)] [(primref op) (primref-loc op)]
[(closure label free)
(cond
[(null? free) (obj x)]
[else (error 'Simple "BUG: not a thunk ~s" x)])]
[else (error 'Simple "what ~s" x)])) [else (error 'Simple "what ~s" x)]))
(define (do-fix lhs* rhs* ac) (define (do-fix lhs* rhs* ac)
;;; 1. first, set the code pointers in the right places ;;; 1. first, set the code pointers in the right places