Added an optimization that removes self-references from fix-bound
closures.
This commit is contained in:
Abdulaziz Ghuloum
parent
d6a1a177a9
commit
37aab027da
|
|
@ -29,7 +29,7 @@
|
|||
;;; | (jmpcall <label> <Expr> <Expr>*)
|
||||
;;; | (mvcall <Expr> <clambda>)
|
||||
;;; <codeloc> ::= (code-loc <label>)
|
||||
;;; <clambda> ::= (clambda <label> <case>* <free var>*)
|
||||
;;; <clambda> ::= (clambda <label> <case>* <cp> <free var>*)
|
||||
;;; <case> ::= (clambda-case <info> <body>)
|
||||
;;; <info> ::= (clambda-info label <arg var>* proper)
|
||||
;;; <Program> ::= (codes <clambda>* <Expr>)
|
||||
|
|
@ -106,8 +106,8 @@
|
|||
;;;
|
||||
(define (Clambda x)
|
||||
(struct-case x
|
||||
[(clambda label case* free* name)
|
||||
(make-clambda label (map ClambdaCase case*) free* name)]
|
||||
[(clambda label case* cp free* name)
|
||||
(make-clambda label (map ClambdaCase case*) cp free* name)]
|
||||
[else (error who "invalid clambda" x)]))
|
||||
;;;
|
||||
(define (Program x)
|
||||
|
|
@ -124,15 +124,18 @@
|
|||
;;;
|
||||
(define who 'eliminate-fix)
|
||||
;;;
|
||||
(define (Expr cpvar free*)
|
||||
(define (Expr main-cpvar cpvar free*)
|
||||
;;;
|
||||
(define (Var x)
|
||||
(cond
|
||||
[(eq? x main-cpvar) cpvar]
|
||||
[else
|
||||
(let f ([free* free*] [i 0])
|
||||
(cond
|
||||
[(null? free*) x]
|
||||
[(eq? x (car free*))
|
||||
(make-primcall '$cpref (list cpvar (make-constant i)))]
|
||||
[else (f (cdr free*) (fxadd1 i))])))
|
||||
[else (f (cdr free*) (fxadd1 i))]))]))
|
||||
(define (do-fix lhs* rhs* body)
|
||||
(define (handle-closure x)
|
||||
(struct-case x
|
||||
|
|
@ -168,7 +171,7 @@
|
|||
[else (error who "invalid expr" x)]))
|
||||
Expr)
|
||||
;;;
|
||||
(define (ClambdaCase free*)
|
||||
(define (ClambdaCase main-cp free*)
|
||||
(lambda (x)
|
||||
(struct-case x
|
||||
[(clambda-case info body)
|
||||
|
|
@ -177,20 +180,20 @@
|
|||
(let ([cp (unique-var 'cp)])
|
||||
(make-clambda-case
|
||||
(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)])))
|
||||
;;;
|
||||
(define (Clambda x)
|
||||
(struct-case x
|
||||
[(clambda label case* free* name)
|
||||
(make-clambda label (map (ClambdaCase free*) case*)
|
||||
free* name)]
|
||||
[(clambda label case* cp free* name)
|
||||
(make-clambda label (map (ClambdaCase cp free*) case*)
|
||||
cp free* name)]
|
||||
[else (error who "invalid clambda" x)]))
|
||||
;;;
|
||||
(define (Program x)
|
||||
(struct-case x
|
||||
[(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)]))
|
||||
;;;
|
||||
(Program x))
|
||||
|
|
@ -231,8 +234,8 @@
|
|||
(make-clambda-case info (Main body))]))
|
||||
(define (CodeExpr x)
|
||||
(struct-case x
|
||||
[(clambda L cases free name)
|
||||
(make-clambda L (map CaseExpr cases) free name)]))
|
||||
[(clambda L cases cp free name)
|
||||
(make-clambda L (map CaseExpr cases) cp free name)]))
|
||||
(define (CodesExpr x)
|
||||
(struct-case x
|
||||
[(codes list body)
|
||||
|
|
@ -283,8 +286,8 @@
|
|||
;;;
|
||||
(define (Clambda x)
|
||||
(struct-case x
|
||||
[(clambda label case* free* name)
|
||||
(make-clambda label (map ClambdaCase case*) free* name)]))
|
||||
[(clambda label case* cp free* name)
|
||||
(make-clambda label (map ClambdaCase case*) cp free* name)]))
|
||||
;;;
|
||||
(define (Main x)
|
||||
(if (Tail x)
|
||||
|
|
@ -758,8 +761,8 @@
|
|||
;;;
|
||||
(define (Clambda x)
|
||||
(struct-case x
|
||||
[(clambda label case* free* name)
|
||||
(make-clambda label (map ClambdaCase case*) free* name)]))
|
||||
[(clambda label case* cp free* name)
|
||||
(make-clambda label (map ClambdaCase case*) cp free* name)]))
|
||||
;;;
|
||||
(define (Main x)
|
||||
(set! locals '())
|
||||
|
|
@ -1813,8 +1816,8 @@
|
|||
;;;
|
||||
(define (Clambda x)
|
||||
(struct-case x
|
||||
[(clambda label case* free* name)
|
||||
(make-clambda label (map ClambdaCase case*) free* name)]))
|
||||
[(clambda label case* cp free* name)
|
||||
(make-clambda label (map ClambdaCase case*) cp free* name)]))
|
||||
;;;
|
||||
(define (Program x)
|
||||
(struct-case x
|
||||
|
|
@ -2323,8 +2326,8 @@
|
|||
;;;
|
||||
(define (Clambda x)
|
||||
(struct-case x
|
||||
[(clambda label case* free* name)
|
||||
(make-clambda label (map ClambdaCase case*) free* name)]))
|
||||
[(clambda label case* cp free* name)
|
||||
(make-clambda label (map ClambdaCase case*) cp free* name)]))
|
||||
;;;
|
||||
(define (Program x)
|
||||
(struct-case x
|
||||
|
|
@ -2793,7 +2796,7 @@
|
|||
;;;
|
||||
(define (Clambda x)
|
||||
(struct-case x
|
||||
[(clambda L case* free* name)
|
||||
[(clambda L case* cp free* name)
|
||||
(cons* (length free*)
|
||||
`(name ,name)
|
||||
(label L)
|
||||
|
|
|
|||
|
|
@ -126,7 +126,7 @@
|
|||
(define-struct seq (e0 e1))
|
||||
(define-struct case-info (label args proper))
|
||||
(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 funcall (op rand*))
|
||||
(define-struct jmpcall (label op rand*))
|
||||
|
|
@ -313,7 +313,7 @@
|
|||
(list? fml*))
|
||||
body)))))
|
||||
(cdr x))])
|
||||
(make-clambda (gensym) cls* #f ctxt))]
|
||||
(make-clambda (gensym) cls* #f #f ctxt))]
|
||||
[(lambda)
|
||||
(E `(case-lambda ,(cdr x)) ctxt)]
|
||||
[(foreign-call)
|
||||
|
|
@ -385,10 +385,9 @@
|
|||
[else (cons (E x) ac)]))
|
||||
(cons 'begin (f e0 (f e1 '()))))]
|
||||
[(clambda-case info body)
|
||||
`(,(E-args (case-info-proper info)
|
||||
(case-info-args info))
|
||||
`(,(E-args (case-info-proper info) (case-info-args info))
|
||||
,(E body))]
|
||||
[(clambda g cls* free)
|
||||
[(clambda g cls* cp free)
|
||||
`(,g (case-lambda . ,(map E cls*)))]
|
||||
[(clambda label clauses free)
|
||||
`(code ,label . ,(map E clauses))]
|
||||
|
|
@ -549,14 +548,14 @@
|
|||
(Expr altern))]
|
||||
[(seq e0 e1)
|
||||
(make-seq (Expr e0) (Expr e1))]
|
||||
[(clambda g cls* free name)
|
||||
[(clambda g cls* cp free name)
|
||||
(make-clambda g
|
||||
(map (lambda (x)
|
||||
(struct-case x
|
||||
[(clambda-case info body)
|
||||
(make-clambda-case info (Expr body))]))
|
||||
cls*)
|
||||
free name)]
|
||||
cp free name)]
|
||||
[(funcall rator rand*)
|
||||
(inline (Expr rator) (map Expr rand*))]
|
||||
[(forcall rator rand*)
|
||||
|
|
@ -694,7 +693,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* free name)
|
||||
[(clambda g cls* cp free name)
|
||||
(make-clambda g
|
||||
(map (lambda (x)
|
||||
(struct-case x
|
||||
|
|
@ -703,7 +702,7 @@
|
|||
(let ([body (E body (extend-hash (case-info-args info) h ref) void)])
|
||||
(make-clambda-case info body)))]))
|
||||
cls*)
|
||||
free name)]
|
||||
cp free name)]
|
||||
[(funcall rator rand*)
|
||||
(let ([rator (E rator ref comp)] [rand* (E* rand* ref comp)])
|
||||
(struct-case rator
|
||||
|
|
@ -1243,14 +1242,14 @@
|
|||
(make-seq (make-seq e0 (seq-e0 e1)) (seq-e1 e1))]
|
||||
[else
|
||||
(make-seq e0 e1)]))
|
||||
(define (do-clambda g cls* free name)
|
||||
(define (do-clambda g cls* cp free name)
|
||||
(make-clambda g
|
||||
(map (lambda (cls)
|
||||
(struct-case cls
|
||||
[(clambda-case info body)
|
||||
(make-clambda-case info (Value body))]))
|
||||
cls*)
|
||||
free name))
|
||||
cp free name))
|
||||
(define (Effect x)
|
||||
(struct-case x
|
||||
[(constant) the-void]
|
||||
|
|
@ -1379,7 +1378,8 @@
|
|||
(make-conditional e0 e1 e2))]
|
||||
[else (make-conditional e0 e1 e2)])))]))]
|
||||
[(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*)
|
||||
(optimize-primcall 'v rator (map Value rand*))]
|
||||
[(funcall rator rand*)
|
||||
|
|
@ -1454,7 +1454,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* free name)
|
||||
[(clambda g cls* cp free name)
|
||||
(make-clambda g
|
||||
(map (lambda (cls)
|
||||
(struct-case cls
|
||||
|
|
@ -1466,7 +1466,7 @@
|
|||
(make-case-info label fml* proper)
|
||||
(bind-assigned a-lhs* a-rhs* (Expr body))))])]))
|
||||
cls*)
|
||||
free name)]
|
||||
cp free name)]
|
||||
[(forcall op rand*)
|
||||
(make-forcall op (map Expr rand*))]
|
||||
[(funcall rator rand*)
|
||||
|
|
@ -1549,7 +1549,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* free name)
|
||||
[(clambda g cls* cp free name)
|
||||
(make-clambda g
|
||||
(map (lambda (cls)
|
||||
(struct-case cls
|
||||
|
|
@ -1557,7 +1557,7 @@
|
|||
(for-each init-var (case-info-args info))
|
||||
(make-clambda-case info (Expr body))]))
|
||||
cls*)
|
||||
free name)]
|
||||
cp free name)]
|
||||
[(forcall op rand*)
|
||||
(make-forcall op (map Expr rand*))]
|
||||
[(funcall rator rand*)
|
||||
|
|
@ -1589,16 +1589,16 @@
|
|||
(let-values ([(a a-free) (Expr (car x*))]
|
||||
[(d d-free) (Expr* (cdr x*))])
|
||||
(values (cons a d) (union a-free d-free)))]))
|
||||
(define (do-clambda* x*)
|
||||
(define (do-clambda* lhs* x*)
|
||||
(cond
|
||||
[(null? x*) (values '() '())]
|
||||
[else
|
||||
(let-values ([(a a-free) (do-clambda (car x*))]
|
||||
[(d d-free) (do-clambda* (cdr x*))])
|
||||
(let-values ([(a a-free) (do-clambda (car lhs*) (car x*))]
|
||||
[(d d-free) (do-clambda* (cdr lhs*) (cdr x*))])
|
||||
(values (cons a d) (union a-free d-free)))]))
|
||||
(define (do-clambda x)
|
||||
(define (do-clambda lhs x)
|
||||
(struct-case x
|
||||
[(clambda g cls* _free name)
|
||||
[(clambda g cls* _cp _free name)
|
||||
(let-values ([(cls* free)
|
||||
(let f ([cls* cls*])
|
||||
(cond
|
||||
|
|
@ -1612,8 +1612,12 @@
|
|||
(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 name) free)
|
||||
free))]))
|
||||
(let ([free (difference free (list lhs))])
|
||||
(values
|
||||
(make-closure
|
||||
(make-clambda g cls* lhs free name)
|
||||
free)
|
||||
free)))]))
|
||||
(define (Expr ex)
|
||||
(struct-case ex
|
||||
[(constant) (values ex '())]
|
||||
|
|
@ -1625,7 +1629,7 @@
|
|||
(values (make-bind lhs* rhs* body)
|
||||
(union rhs-free (difference body-free lhs*))))]
|
||||
[(fix lhs* rhs* body)
|
||||
(let-values ([(rhs* rfree) (do-clambda* rhs*)]
|
||||
(let-values ([(rhs* rfree) (do-clambda* lhs* rhs*)]
|
||||
[(body bfree) (Expr body)])
|
||||
(values (make-fix lhs* rhs* body)
|
||||
(difference (union bfree rfree) lhs*)))]
|
||||
|
|
@ -1640,7 +1644,7 @@
|
|||
[(e1 e1-free) (Expr e1)])
|
||||
(values (make-seq e0 e1) (union e0-free e1-free)))]
|
||||
[(clambda)
|
||||
(do-clambda ex)]
|
||||
(do-clambda #f ex)]
|
||||
[(forcall op rand*)
|
||||
(let-values ([(rand* rand*-free) (Expr* rand*)])
|
||||
(values (make-forcall op rand*) rand*-free))]
|
||||
|
|
@ -1693,7 +1697,7 @@
|
|||
[else #f]))
|
||||
(define (trim/lift-code code free*)
|
||||
(struct-case code
|
||||
[(clambda label cls* free*/dropped name)
|
||||
[(clambda label cls* cp free*/dropped name)
|
||||
(let ([cls* (map
|
||||
(lambda (x)
|
||||
(struct-case x
|
||||
|
|
@ -1704,7 +1708,7 @@
|
|||
cls*)])
|
||||
(let ([g (make-code-loc label)])
|
||||
(set! all-codes
|
||||
(cons (make-clambda label cls* free* name) all-codes))
|
||||
(cons (make-clambda label cls* cp free* name) all-codes))
|
||||
g))]))
|
||||
(define (optimize-one-closure code free)
|
||||
(let ([free (trim-vars free)])
|
||||
|
|
@ -1807,7 +1811,7 @@
|
|||
[(jmpcall label rator rand*) (make-jmpcall label (E rator) (map E rand*))]
|
||||
[(mvcall p c)
|
||||
(struct-case c
|
||||
[(clambda label cases free name)
|
||||
[(clambda label cases cp free name)
|
||||
(make-mvcall (E p)
|
||||
(make-clambda label
|
||||
(map (lambda (x)
|
||||
|
|
@ -1815,10 +1819,17 @@
|
|||
[(clambda-case info body)
|
||||
(make-clambda-case info (E body))]))
|
||||
cases)
|
||||
free name))])]
|
||||
cp free name))])]
|
||||
[else (error who "invalid expression" (unparse x))]))
|
||||
(when (assembler-output)
|
||||
(printf "BEFORE\n")
|
||||
(pretty-print (unparse 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))]))
|
||||
(define (CodeExpr x)
|
||||
(struct-case x
|
||||
[(clambda L cases free name)
|
||||
(make-clambda L (map CaseExpr cases) free name)]))
|
||||
[(clambda L cases cp free name)
|
||||
(make-clambda L (map CaseExpr cases) cp free name)]))
|
||||
(define (CodesExpr x)
|
||||
(struct-case x
|
||||
[(codes list body)
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
1100
|
||||
1101
|
||||
|
|
|
|||
|
|
@ -478,10 +478,10 @@
|
|||
;;;
|
||||
(define (Clambda x)
|
||||
(struct-case x
|
||||
[(clambda label case* free* name)
|
||||
[(clambda label case* cp free* name)
|
||||
(make-clambda label
|
||||
(map ClambdaCase case*)
|
||||
free* name)]
|
||||
cp free* name)]
|
||||
[else (error 'specify-rep "invalid clambda" x)]))
|
||||
;;;
|
||||
(define (Program x)
|
||||
|
|
|
|||
Loading…
Reference in New Issue