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

Added an optimization that removes self-references from fix-bound 

closures.
This commit is contained in:
Abdulaziz Ghuloum 2007-11-21 04:00:10 -05:00
parent d6a1a177a9
commit 37aab027da
4 changed files with 77 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
scheme/ikarus.compiler.altcogen.ss
View File

@ -29,7 +29,7 @@
;;; | (jmpcall <label> <Expr> <Expr>*) ;;; | (jmpcall <label> <Expr> <Expr>*)
;;; | (mvcall <Expr> <clambda>) ;;; | (mvcall <Expr> <clambda>)
;;; <codeloc> ::= (code-loc <label>) ;;; <codeloc> ::= (code-loc <label>)
;;; <clambda> ::= (clambda <label> <case>* <free var>*) ;;; <clambda> ::= (clambda <label> <case>* <cp> <free var>*)
;;; <case> ::= (clambda-case <info> <body>) ;;; <case> ::= (clambda-case <info> <body>)
;;; <info> ::= (clambda-info label <arg var>* proper) ;;; <info> ::= (clambda-info label <arg var>* proper)
;;; <Program> ::= (codes <clambda>* <Expr>) ;;; <Program> ::= (codes <clambda>* <Expr>)
@ -106,8 +106,8 @@
;;; ;;;
(define (Clambda x) (define (Clambda x)
(struct-case x (struct-case x
[(clambda label case* free* name) [(clambda label case* cp free* name)
(make-clambda label (map ClambdaCase case*) free* name)] (make-clambda label (map ClambdaCase case*) cp free* name)]
[else (error who "invalid clambda" x)])) [else (error who "invalid clambda" x)]))
;;; ;;;
(define (Program x) (define (Program x)
@ -124,15 +124,18 @@
;;; ;;;
(define who 'eliminate-fix) (define who 'eliminate-fix)
;;; ;;;
(define (Expr cpvar free*) (define (Expr main-cpvar cpvar free*)
;;; ;;;
(define (Var x) (define (Var x)
(let f ([free* free*] [i 0]) (cond
(cond [(eq? x main-cpvar) cpvar]
[(null? free*) x] [else
[(eq? x (car free*)) (let f ([free* free*] [i 0])
(make-primcall '$cpref (list cpvar (make-constant i)))] (cond
[else (f (cdr free*) (fxadd1 i))]))) [(null? free*) x]
[(eq? x (car free*))
(make-primcall '$cpref (list cpvar (make-constant i)))]
[else (f (cdr free*) (fxadd1 i))]))]))
(define (do-fix lhs* rhs* body) (define (do-fix lhs* rhs* body)
(define (handle-closure x) (define (handle-closure x)
(struct-case x (struct-case x
@ -168,7 +171,7 @@
[else (error who "invalid expr" x)])) [else (error who "invalid expr" x)]))
Expr) Expr)
;;; ;;;
(define (ClambdaCase free*) (define (ClambdaCase main-cp free*)
(lambda (x) (lambda (x)
(struct-case x (struct-case x
[(clambda-case info body) [(clambda-case info body)
@ -177,20 +180,20 @@
(let ([cp (unique-var 'cp)]) (let ([cp (unique-var 'cp)])
(make-clambda-case (make-clambda-case
(make-case-info label (cons cp args) proper) (make-case-info label (cons cp args) proper)
((Expr cp free*) body)))])] ((Expr main-cp cp free*) body)))])]
[else (error who "invalid clambda-case" x)]))) [else (error who "invalid clambda-case" x)])))
;;; ;;;
(define (Clambda x) (define (Clambda x)
(struct-case x (struct-case x
[(clambda label case* free* name) [(clambda label case* cp free* name)
(make-clambda label (map (ClambdaCase free*) case*) (make-clambda label (map (ClambdaCase cp free*) case*)
free* name)] cp free* name)]
[else (error who "invalid clambda" x)])) [else (error who "invalid clambda" x)]))
;;; ;;;
(define (Program x) (define (Program x)
(struct-case x (struct-case x
[(codes code* body) [(codes code* body)
(make-codes (map Clambda code*) ((Expr #f '()) body))] (make-codes (map Clambda code*) ((Expr #f #f '()) body))]
[else (error who "invalid program" x)])) [else (error who "invalid program" x)]))
;;; ;;;
(Program x)) (Program x))
@ -231,8 +234,8 @@
(make-clambda-case info (Main body))])) (make-clambda-case info (Main body))]))
(define (CodeExpr x) (define (CodeExpr x)
(struct-case x (struct-case x
[(clambda L cases free name) [(clambda L cases cp free name)
(make-clambda L (map CaseExpr cases) free name)])) (make-clambda L (map CaseExpr cases) cp free name)]))
(define (CodesExpr x) (define (CodesExpr x)
(struct-case x (struct-case x
[(codes list body) [(codes list body)
@ -283,8 +286,8 @@
;;; ;;;
(define (Clambda x) (define (Clambda x)
(struct-case x (struct-case x
[(clambda label case* free* name) [(clambda label case* cp free* name)
(make-clambda label (map ClambdaCase case*) free* name)])) (make-clambda label (map ClambdaCase case*) cp free* name)]))
;;; ;;;
(define (Main x) (define (Main x)
(if (Tail x) (if (Tail x)
@ -758,8 +761,8 @@
;;; ;;;
(define (Clambda x) (define (Clambda x)
(struct-case x (struct-case x
[(clambda label case* free* name) [(clambda label case* cp free* name)
(make-clambda label (map ClambdaCase case*) free* name)])) (make-clambda label (map ClambdaCase case*) cp free* name)]))
;;; ;;;
(define (Main x) (define (Main x)
(set! locals '()) (set! locals '())
@ -1813,8 +1816,8 @@
;;; ;;;
(define (Clambda x) (define (Clambda x)
(struct-case x (struct-case x
[(clambda label case* free* name) [(clambda label case* cp free* name)
(make-clambda label (map ClambdaCase case*) free* name)])) (make-clambda label (map ClambdaCase case*) cp free* name)]))
;;; ;;;
(define (Program x) (define (Program x)
(struct-case x (struct-case x
@ -2323,8 +2326,8 @@
;;; ;;;
(define (Clambda x) (define (Clambda x)
(struct-case x (struct-case x
[(clambda label case* free* name) [(clambda label case* cp free* name)
(make-clambda label (map ClambdaCase case*) free* name)])) (make-clambda label (map ClambdaCase case*) cp free* name)]))
;;; ;;;
(define (Program x) (define (Program x)
(struct-case x (struct-case x
@ -2793,7 +2796,7 @@
;;; ;;;
(define (Clambda x) (define (Clambda x)
(struct-case x (struct-case x
[(clambda L case* free* name) [(clambda L case* cp free* name)
(cons* (length free*) (cons* (length free*)
`(name ,name) `(name ,name)
(label L) (label L)

77
scheme/ikarus.compiler.ss
View File

@ -126,7 +126,7 @@
(define-struct seq (e0 e1)) (define-struct seq (e0 e1))
(define-struct case-info (label args proper)) (define-struct case-info (label args proper))
(define-struct clambda-case (info body)) (define-struct clambda-case (info body))
(define-struct clambda (label cases free name)) (define-struct clambda (label cases cp free name))
(define-struct closure (code free*)) (define-struct closure (code free*))
(define-struct funcall (op rand*)) (define-struct funcall (op rand*))
(define-struct jmpcall (label op rand*)) (define-struct jmpcall (label op rand*))
@ -313,7 +313,7 @@
(list? fml*)) (list? fml*))
body))))) body)))))
(cdr x))]) (cdr x))])
(make-clambda (gensym) cls* #f ctxt))] (make-clambda (gensym) cls* #f #f ctxt))]
[(lambda) [(lambda)
(E `(case-lambda ,(cdr x)) ctxt)] (E `(case-lambda ,(cdr x)) ctxt)]
[(foreign-call) [(foreign-call)
@ -385,10 +385,9 @@
[else (cons (E x) ac)])) [else (cons (E x) ac)]))
(cons 'begin (f e0 (f e1 '()))))] (cons 'begin (f e0 (f e1 '()))))]
[(clambda-case info body) [(clambda-case info body)
`(,(E-args (case-info-proper info) `(,(E-args (case-info-proper info) (case-info-args info))
(case-info-args info)) ,(E body))]
,(E body))] [(clambda g cls* cp free)
[(clambda g cls* free)
`(,g (case-lambda . ,(map E cls*)))] `(,g (case-lambda . ,(map E cls*)))]
[(clambda label clauses free) [(clambda label clauses free)
`(code ,label . ,(map E clauses))] `(code ,label . ,(map E clauses))]
@ -549,14 +548,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* free name) [(clambda g cls* cp free name)
(make-clambda g (make-clambda g
(map (lambda (x) (map (lambda (x)
(struct-case x (struct-case x
[(clambda-case info body) [(clambda-case info body)
(make-clambda-case info (Expr body))])) (make-clambda-case info (Expr body))]))
cls*) cls*)
free name)] cp 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*)
@ -694,7 +693,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* free name) [(clambda g cls* cp free name)
(make-clambda g (make-clambda g
(map (lambda (x) (map (lambda (x)
(struct-case x (struct-case x
@ -703,7 +702,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*)
free name)] cp 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)])
(struct-case rator (struct-case rator
@ -1243,14 +1242,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* free name) (define (do-clambda g cls* cp free name)
(make-clambda g (make-clambda g
(map (lambda (cls) (map (lambda (cls)
(struct-case cls (struct-case cls
[(clambda-case info body) [(clambda-case info body)
(make-clambda-case info (Value body))])) (make-clambda-case info (Value body))]))
cls*) cls*)
free name)) cp free name))
(define (Effect x) (define (Effect x)
(struct-case x (struct-case x
[(constant) the-void] [(constant) the-void]
@ -1379,7 +1378,8 @@
(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* free name) (do-clambda g cls* free name)] [(clambda g cls* cp free name)
(do-clambda g cls* cp 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*)
@ -1454,7 +1454,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* free name) [(clambda g cls* cp free name)
(make-clambda g (make-clambda g
(map (lambda (cls) (map (lambda (cls)
(struct-case cls (struct-case cls
@ -1466,7 +1466,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*)
free name)] cp 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*)
@ -1549,7 +1549,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* free name) [(clambda g cls* cp free name)
(make-clambda g (make-clambda g
(map (lambda (cls) (map (lambda (cls)
(struct-case cls (struct-case cls
@ -1557,7 +1557,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*)
free name)] cp 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*)
@ -1589,16 +1589,16 @@
(let-values ([(a a-free) (Expr (car x*))] (let-values ([(a a-free) (Expr (car x*))]
[(d d-free) (Expr* (cdr x*))]) [(d d-free) (Expr* (cdr x*))])
(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* lhs* x*)
(cond (cond
[(null? x*) (values '() '())] [(null? x*) (values '() '())]
[else [else
(let-values ([(a a-free) (do-clambda (car x*))] (let-values ([(a a-free) (do-clambda (car lhs*) (car x*))]
[(d d-free) (do-clambda* (cdr x*))]) [(d d-free) (do-clambda* (cdr lhs*) (cdr x*))])
(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 lhs x)
(struct-case x (struct-case x
[(clambda g cls* _free name) [(clambda g cls* _cp _free name)
(let-values ([(cls* free) (let-values ([(cls* free)
(let f ([cls* cls*]) (let f ([cls* cls*])
(cond (cond
@ -1612,8 +1612,12 @@
(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 name) free) (let ([free (difference free (list lhs))])
free))])) (values
(make-closure
(make-clambda g cls* lhs free name)
free)
free)))]))
(define (Expr ex) (define (Expr ex)
(struct-case ex (struct-case ex
[(constant) (values ex '())] [(constant) (values ex '())]
@ -1625,7 +1629,7 @@
(values (make-bind lhs* rhs* body) (values (make-bind lhs* rhs* body)
(union rhs-free (difference body-free lhs*))))] (union rhs-free (difference body-free lhs*))))]
[(fix lhs* rhs* body) [(fix lhs* rhs* body)
(let-values ([(rhs* rfree) (do-clambda* rhs*)] (let-values ([(rhs* rfree) (do-clambda* lhs* rhs*)]
[(body bfree) (Expr body)]) [(body bfree) (Expr body)])
(values (make-fix lhs* rhs* body) (values (make-fix lhs* rhs* body)
(difference (union bfree rfree) lhs*)))] (difference (union bfree rfree) lhs*)))]
@ -1640,7 +1644,7 @@
[(e1 e1-free) (Expr e1)]) [(e1 e1-free) (Expr e1)])
(values (make-seq e0 e1) (union e0-free e1-free)))] (values (make-seq e0 e1) (union e0-free e1-free)))]
[(clambda) [(clambda)
(do-clambda ex)] (do-clambda #f ex)]
[(forcall op rand*) [(forcall op rand*)
(let-values ([(rand* rand*-free) (Expr* rand*)]) (let-values ([(rand* rand*-free) (Expr* rand*)])
(values (make-forcall op rand*) rand*-free))] (values (make-forcall op rand*) rand*-free))]
@ -1693,7 +1697,7 @@
[else #f])) [else #f]))
(define (trim/lift-code code free*) (define (trim/lift-code code free*)
(struct-case code (struct-case code
[(clambda label cls* free*/dropped name) [(clambda label cls* cp free*/dropped name)
(let ([cls* (map (let ([cls* (map
(lambda (x) (lambda (x)
(struct-case x (struct-case x
@ -1704,7 +1708,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* name) all-codes)) (cons (make-clambda label cls* cp 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)])
@ -1807,7 +1811,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)
(struct-case c (struct-case c
[(clambda label cases free name) [(clambda label cases cp free name)
(make-mvcall (E p) (make-mvcall (E p)
(make-clambda label (make-clambda label
(map (lambda (x) (map (lambda (x)
@ -1815,10 +1819,17 @@
[(clambda-case info body) [(clambda-case info body)
(make-clambda-case info (E body))])) (make-clambda-case info (E body))]))
cases) cases)
free name))])] cp free name))])]
[else (error who "invalid expression" (unparse x))])) [else (error who "invalid expression" (unparse x))]))
(when (assembler-output)
(printf "BEFORE\n")
(pretty-print (unparse x)))
(let ([x (E x)]) (let ([x (E x)])
(make-codes all-codes x))) (let ([v (make-codes all-codes x)])
(when (assembler-output)
(printf "AFTER\n")
(pretty-print (unparse v)))
v)))
@ -1836,8 +1847,8 @@
(make-clambda-case info (Tail body))])) (make-clambda-case info (Tail body))]))
(define (CodeExpr x) (define (CodeExpr x)
(struct-case x (struct-case x
[(clambda L cases free name) [(clambda L cases cp free name)
(make-clambda L (map CaseExpr cases) free name)])) (make-clambda L (map CaseExpr cases) cp free name)]))
(define (CodesExpr x) (define (CodesExpr x)
(struct-case x (struct-case x
[(codes list body) [(codes list body)

2
scheme/last-revision
View File

@ -1 +1 @@
1100 1101

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

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