Work in progress on reimplementing the optimizer based on
Oscar Waddell's dissertation (chapter 4). The existing optimizer in Ikarus is just a joke.
This commit is contained in:
Abdulaziz Ghuloum
parent
08fda34ebe
commit
66b9f6968e
|
|
@ -5,7 +5,8 @@ EXTRA_DIST=ikarus.boot.prebuilt ikarus.enumerations.ss \
|
|||
ikarus.exceptions.ss ikarus.apply.ss ikarus.bytevectors.ss \
|
||||
ikarus.cafe.ss ikarus.chars.ss ikarus.code-objects.ss \
|
||||
ikarus.codecs.ss ikarus.collect.ss ikarus.command-line.ss \
|
||||
ikarus.compiler.altcogen.ss ikarus.compiler.ss ikarus.control.ss \
|
||||
ikarus.compiler.altcogen.ss ikarus.compiler.ss \
|
||||
ikarus.compiler.source-optimizer.ss ikarus.control.ss \
|
||||
ikarus.date-string.ss ikarus.fasl.ss ikarus.fasl.write.ss \
|
||||
ikarus.fixnums.ss ikarus.guardians.ss ikarus.handlers.ss \
|
||||
ikarus.hash-tables.ss ikarus.intel-assembler.ss \
|
||||
|
|
@ -23,7 +24,7 @@ EXTRA_DIST=ikarus.boot.prebuilt ikarus.enumerations.ss \
|
|||
psyntax.internal.ss psyntax.library-manager.ss \
|
||||
ikarus/code-objects.ss ikarus/compiler.ss ikarus/intel-assembler.ss \
|
||||
ikarus/fasl/write.ss unicode/unicode-char-cases.ss \
|
||||
unicode/unicode-charinfo.ss ikarus.io.ss ikarus.time-and-date.ss
|
||||
unicode/unicode-charinfo.ss ikarus.io.ss ikarus.time-and-date.ss
|
||||
|
||||
all: $(nodist_pkglib_DATA)
|
||||
|
||||
|
|
|
|||
|
|
@ -159,7 +159,8 @@ EXTRA_DIST = ikarus.boot.prebuilt ikarus.enumerations.ss \
|
|||
ikarus.exceptions.ss ikarus.apply.ss ikarus.bytevectors.ss \
|
||||
ikarus.cafe.ss ikarus.chars.ss ikarus.code-objects.ss \
|
||||
ikarus.codecs.ss ikarus.collect.ss ikarus.command-line.ss \
|
||||
ikarus.compiler.altcogen.ss ikarus.compiler.ss ikarus.control.ss \
|
||||
ikarus.compiler.altcogen.ss ikarus.compiler.ss \
|
||||
ikarus.compiler.source-optimizer.ss ikarus.control.ss \
|
||||
ikarus.date-string.ss ikarus.fasl.ss ikarus.fasl.write.ss \
|
||||
ikarus.fixnums.ss ikarus.guardians.ss ikarus.handlers.ss \
|
||||
ikarus.hash-tables.ss ikarus.intel-assembler.ss \
|
||||
|
|
@ -177,7 +178,7 @@ EXTRA_DIST = ikarus.boot.prebuilt ikarus.enumerations.ss \
|
|||
psyntax.internal.ss psyntax.library-manager.ss \
|
||||
ikarus/code-objects.ss ikarus/compiler.ss ikarus/intel-assembler.ss \
|
||||
ikarus/fasl/write.ss unicode/unicode-char-cases.ss \
|
||||
unicode/unicode-charinfo.ss ikarus.io.ss ikarus.time-and-date.ss
|
||||
unicode/unicode-charinfo.ss ikarus.io.ss ikarus.time-and-date.ss
|
||||
|
||||
revno = "$(shell sed 's/ .*//' ../.bzr/branch/last-revision 2>/dev/null)"
|
||||
CLEANFILES = $(nodist_pkglib_DATA) ikarus.config.ss
|
||||
|
|
|
|||
|
|
@ -0,0 +1,187 @@
|
|||
|
||||
;;; Work in progress
|
||||
(define (source-optimize x) x)
|
||||
|
||||
#!eof
|
||||
|
||||
|
||||
;;; Oscar Waddell. "Extending the Scope of Syntactic Abstraction". PhD.
|
||||
;;; Thesis. Indiana University Computer Science Department. August 1999.
|
||||
;;; Available online:
|
||||
;;; http://www.cs.indiana.edu/~owaddell/papers/thesis.ps.gz
|
||||
|
||||
(module (source-optimize)
|
||||
(define who 'source-optimize)
|
||||
(define-struct info (source-referenced source-assigned
|
||||
residual-referenced residual-assigned))
|
||||
(module (init-var! var-info)
|
||||
(define (init-var! x)
|
||||
(set-var-index! x (make-info #f #f #f #f)))
|
||||
(define (var-info x)
|
||||
(let ([v (var-index x)])
|
||||
(if (info? v)
|
||||
v
|
||||
(error 'var-info "not initialized" x)))))
|
||||
;;; purpose of prepare:
|
||||
;;; 1. attach an info struct to every bound variable
|
||||
;;; 2. set the plref and plset flags to indicate whether
|
||||
;;; there is a reference/assignment to the variable.
|
||||
;;; 3. verify well-formness of the input.
|
||||
(define (prepare x)
|
||||
(define (L x)
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(struct-case x
|
||||
[(clambda-case info body)
|
||||
(for-each init-var! (case-info-args info))
|
||||
(E body)]))
|
||||
(clambda-cases x)))
|
||||
(define (E x)
|
||||
(struct-case x
|
||||
[(constant) (void)]
|
||||
[(var) (set-info-source-refereced! (var-info x) #t)]
|
||||
[(primref) (void)]
|
||||
[(clambda) (L x)]
|
||||
[(seq e0 e1) (E e0) (E e1)]
|
||||
[(conditional e0 e1 e2)
|
||||
(E e0) (E e1) (E e2)]
|
||||
[(assign x val)
|
||||
(set-info-source-assigned! (var-info x) #t)
|
||||
(E val)]
|
||||
[(bind lhs* rhs* body)
|
||||
(for-each E rhs*)
|
||||
(for-each init-var! lhs*)
|
||||
(E body)]
|
||||
[(fix lhs* rhs* body)
|
||||
(for-each init-var! lhs*)
|
||||
(for-each L rhs*)
|
||||
(E body)
|
||||
(for-each ;;; sanity check
|
||||
(lambda (x)
|
||||
(assert (not (info-source-assigned (var-info x)))))
|
||||
lhs*)]
|
||||
[(funcall rator rand*)
|
||||
(for-each E rand*)
|
||||
(E rator)]
|
||||
[(forcall name rand*)
|
||||
(for-each E rand*)]
|
||||
[else (error who "invalid expr in prepare" x)]))
|
||||
(E x))
|
||||
;;; business
|
||||
(define (mkseq e0 e1)
|
||||
;;; returns a (seq e0 e1) with a seq-less e1 if both
|
||||
;;; e0 and e1 are constructed properly.
|
||||
(if (simple? e0)
|
||||
e1
|
||||
(let ([e0 (struct-case e0
|
||||
[(seq e0a e0b) (if (simple? e0b) e0a e0)]
|
||||
[else e0])])
|
||||
(struct-case e1
|
||||
[(seq e1a e1b) (make-seq (make-seq e0 e1a) e1b)]
|
||||
[else (make-seq e0 e1)]))))
|
||||
;;; simple?: check quickly whether something is effect-free
|
||||
(define (simple? x)
|
||||
(struct-case x
|
||||
[(constant) #t]
|
||||
[(var) #t]
|
||||
[(primref) #t]
|
||||
[(clambda) #t]
|
||||
[else #f]))
|
||||
;;; result returns the "last" value of an expression
|
||||
(define (result x)
|
||||
(struct-case x
|
||||
[(seq e0 e1) e1]
|
||||
[else x]))
|
||||
(define (records-equal? x y)
|
||||
(struct-case x
|
||||
[(constant kx)
|
||||
(struct-case y
|
||||
[(constant ky)
|
||||
(ctxt-case ctxt
|
||||
[(e) #t]
|
||||
[(p) (if kx ky (not ky))]
|
||||
[else (eq? kx ky)])]
|
||||
[else #f])]
|
||||
[else #f]))
|
||||
(module (E-call)
|
||||
(define (residualize-operands e rand*)
|
||||
(cond
|
||||
[(null? rand*) e]
|
||||
[(not (rand-residualize-for-effect (car rand*)))
|
||||
(residualize-operands e (cdr rand*))]
|
||||
[else
|
||||
(let ([e1 (process-rands-for-effect rand*)])
|
||||
(mkseq e1 (residualize-operands e (cdr rand*))))]))
|
||||
(define (value-visit-operand! rand)
|
||||
(or (rand-value rand)
|
||||
(let ([e (E (rand-expr rand) (rand-env rand) 'v)])
|
||||
(set-rand-value! rand e)
|
||||
e)))
|
||||
(define (E-call rator rand* env ctxt)
|
||||
(let ([ctxt (make-app-ctxt rand* ctxt)])
|
||||
(let ([rator (E rator env ctxt)])
|
||||
(if (app-inlined ctxt)
|
||||
(residualize-operand rator rand*)
|
||||
(make-funcall rator
|
||||
(map value-visit-operand! rand*)))))))
|
||||
(define (E x env ctxt)
|
||||
(struct-case x
|
||||
[(constant) x]
|
||||
[(var) (E-var x env ctxt)]
|
||||
[(seq e0 e1)
|
||||
(mkseq (E e0 env 'e) (E e1 env ctxt))]
|
||||
[(conditional e0 e1 e2)
|
||||
(let ([e0 (E e0 env 'p)])
|
||||
(struct-case (result e0)
|
||||
[(constant k)
|
||||
(mkseq e0 (E (if k e1 e2) env ctxt))]
|
||||
[else
|
||||
(let ([ctxt (ctxt-case ctxt [(app) 'v] [else ctxt])])
|
||||
(let ([e1 (E e1 env ctxt)]
|
||||
[e2 (E e2 env ctxt)])
|
||||
(if (records-equal? e1 e2 ctxt)
|
||||
(mkseq e0 e1)
|
||||
(make-conditional e0 e1 e2))))]))]
|
||||
[(assign x v)
|
||||
(mkseq
|
||||
(let ([xi (var-info x)])
|
||||
(cond
|
||||
[(not (info-source-referenced xi))
|
||||
;;; dead on arrival
|
||||
(E v env 'e)]
|
||||
[else
|
||||
(set-info-residual-assigned! i #t)
|
||||
(make-assign x (E v env 'v))]))
|
||||
(make-constant (void)))]
|
||||
[(funcall rator rand*)
|
||||
(E-call rator (map (mkoperand env) rand*) env ctxt)]
|
||||
[(primref name)
|
||||
(ctxt-case ctxt
|
||||
[(app) (E-fold-prim name env ctxt)]
|
||||
[(value) x]
|
||||
[else (make-constant (void))])]
|
||||
[(clambda g cases cp free name)
|
||||
(ctxt-case ctxt
|
||||
[(app) (E-inline x env ctxt)]
|
||||
[(p e) (make-constant (void))]
|
||||
[else
|
||||
(make-clambda g
|
||||
(map
|
||||
(lambda (x)
|
||||
(struct-case x
|
||||
[(clambda-case info body)
|
||||
(struct-case info
|
||||
[(case-info label args proper)
|
||||
(with-extended-env ((env args) (env args #f))
|
||||
(make-clambda-case
|
||||
(make-info label args proper)
|
||||
(E body env 'v)))])]))
|
||||
cases)
|
||||
cp free name)])]
|
||||
[else (error who "invalid expression" x)]))
|
||||
(define (source-optimize expr)
|
||||
(prepare expr)
|
||||
(E expr 'v)))
|
||||
|
||||
|
||||
|
||||
|
|
@ -837,7 +837,7 @@
|
|||
[else
|
||||
(values '()
|
||||
(mklet (list (binding-lhs b))
|
||||
(list (make-primcall 'void '()))
|
||||
(list (make-funcall (make-primref 'void) '()))
|
||||
(mkset!s scc
|
||||
(mkfix fix* body))))]))]
|
||||
[else
|
||||
|
|
@ -851,7 +851,8 @@
|
|||
(if ordered? (sort-bindings complex*) complex*)])
|
||||
(values '()
|
||||
(mklet (map binding-lhs complex*)
|
||||
(map (lambda (x) (make-primcall 'void '()))
|
||||
(map (lambda (x)
|
||||
(make-funcall (make-primref 'void) '()))
|
||||
complex*)
|
||||
(mkfix (append lambda* fix*)
|
||||
(mkset!s complex* body)))))]))]))
|
||||
|
|
@ -984,6 +985,10 @@
|
|||
;(pretty-print (unparse x))
|
||||
x))
|
||||
|
||||
|
||||
(include "ikarus.compiler.source-optimizer.ss")
|
||||
|
||||
|
||||
(define (uncover-assigned/referenced x)
|
||||
(define who 'uncover-assigned/referenced)
|
||||
(define (Expr* x*)
|
||||
|
|
@ -3048,6 +3053,7 @@
|
|||
[p (if (scc-letrec)
|
||||
(optimize-letrec/scc p)
|
||||
(optimize-letrec p))]
|
||||
[p (source-optimize p)]
|
||||
[p (uncover-assigned/referenced p)]
|
||||
[p (copy-propagate p)]
|
||||
[p (rewrite-assignments p)]
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
1381
|
||||
1382
|
||||
|
|
|
|||
Loading…
Reference in New Issue