Some work on optimizer (still not working).
This commit is contained in:
Abdulaziz Ghuloum
parent
19e5d2bacd
commit
1d6d5bec61
|
|
@ -1,8 +1,6 @@
|
|||
|
||||
;;; Work in progress
|
||||
(define (source-optimize x) x)
|
||||
|
||||
#!eof
|
||||
|
||||
|
||||
;;; Oscar Waddell. "Extending the Scope of Syntactic Abstraction". PhD.
|
||||
|
|
@ -10,18 +8,68 @@
|
|||
;;; Available online:
|
||||
;;; http://www.cs.indiana.edu/~owaddell/papers/thesis.ps.gz
|
||||
|
||||
(module (source-optimize)
|
||||
(module (source-optimize optimize-level)
|
||||
(define who 'source-optimize)
|
||||
(define-struct info (source-referenced source-assigned
|
||||
residual-referenced residual-assigned))
|
||||
;;; this define-structure definition for compatibility with the
|
||||
;;; notation used in Oscar's thesis.
|
||||
(define-syntax define-structure
|
||||
(lambda (stx)
|
||||
(define (fmt ctxt)
|
||||
(lambda (str . args)
|
||||
(datum->syntax ctxt
|
||||
(string->symbol
|
||||
(apply format str (map syntax->datum args))))))
|
||||
(syntax-case stx ()
|
||||
[(_ (name fields ...))
|
||||
#'(define-struct name (fields ...))]
|
||||
[(_ (name fields ...) ([others defaults] ...))
|
||||
(with-syntax ([(pred maker (getters ...) (setters ...))
|
||||
(let ([fmt (fmt #'name)])
|
||||
(list (fmt "~s?" #'name)
|
||||
(fmt "make-~s" #'name)
|
||||
(map (lambda (x) (fmt "~s-~s" #'name x))
|
||||
#'(fields ... others ...))
|
||||
(map (lambda (x) (fmt "set-~s-~s!" #'name x))
|
||||
#'(fields ... others ...))))])
|
||||
#'(module (name pred getters ... setters ... maker)
|
||||
(module P (name pred getters ... setters ... maker)
|
||||
(define-struct name (fields ... others ...)))
|
||||
(module (maker)
|
||||
(define (maker fields ...)
|
||||
(import P)
|
||||
(maker fields ... defaults ...)))
|
||||
(module (name pred getters ... setters ...)
|
||||
(import P))))])))
|
||||
;;;
|
||||
(define-structure (prelex name operand)
|
||||
([source-referenced? #f]
|
||||
[source-assigned? #f]
|
||||
[residual-referenced? #f]
|
||||
[residual-assigned? #f]))
|
||||
;;;
|
||||
(define-structure (app rand* ctxt)
|
||||
([inlined #f]))
|
||||
;;;
|
||||
(define-structure (operand expr env)
|
||||
([value #f]
|
||||
[residualize-for-effect #f]))
|
||||
;;;
|
||||
(module (init-var! var-info)
|
||||
(define (init-var! x)
|
||||
(set-var-index! x (make-info #f #f #f #f)))
|
||||
(define (init-var! x)
|
||||
(set-var-index! x (make-prelex #f #f)))
|
||||
(define (var-info x)
|
||||
(let ([v (var-index x)])
|
||||
(if (info? v)
|
||||
(if (prelex? v)
|
||||
v
|
||||
(error 'var-info "not initialized" x)))))
|
||||
(module (with-extended-env)
|
||||
(define (extend e args rands)
|
||||
(error 'extend "not yet"))
|
||||
(define-syntax with-extended-env
|
||||
(syntax-rules ()
|
||||
[(_ ((e2 args2) (e1 args1 rands)) b b* ...)
|
||||
(let-values ([(e2 args2) (extend e1 args1 rands)])
|
||||
b b* ...)])))
|
||||
;;; purpose of prepare:
|
||||
;;; 1. attach an info struct to every bound variable
|
||||
;;; 2. set the plref and plset flags to indicate whether
|
||||
|
|
@ -39,14 +87,14 @@
|
|||
(define (E x)
|
||||
(struct-case x
|
||||
[(constant) (void)]
|
||||
[(var) (set-info-source-refereced! (var-info x) #t)]
|
||||
[(var) (set-prelex-source-referenced?! (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)
|
||||
(set-prelex-source-assigned?! (var-info x) #t)
|
||||
(E val)]
|
||||
[(bind lhs* rhs* body)
|
||||
(for-each E rhs*)
|
||||
|
|
@ -58,7 +106,7 @@
|
|||
(E body)
|
||||
(for-each ;;; sanity check
|
||||
(lambda (x)
|
||||
(assert (not (info-source-assigned (var-info x)))))
|
||||
(assert (not (prelex-source-assigned? (var-info x)))))
|
||||
lhs*)]
|
||||
[(funcall rator rand*)
|
||||
(for-each E rand*)
|
||||
|
|
@ -68,6 +116,29 @@
|
|||
[else (error who "invalid expr in prepare" x)]))
|
||||
(E x))
|
||||
;;; business
|
||||
(define-syntax ctxt-case
|
||||
(lambda (stx)
|
||||
(define (test x)
|
||||
(case (syntax->datum x)
|
||||
[(p) #'(eq? t 'p)]
|
||||
[(v) #'(eq? t 'v)]
|
||||
[(e) #'(eq? t 'e)]
|
||||
[(app) #'(app? t)]
|
||||
[else (syntax-violation stx "invalid ctxt" x)]))
|
||||
(define (extract cls*)
|
||||
(syntax-case cls* (else)
|
||||
[([else e e* ...]) #'(begin e e* ...)]
|
||||
[([(t* ...) e e* ...] rest ...)
|
||||
(with-syntax ([(t* ...) (map test #'(t* ...))]
|
||||
[body (extract #'(rest ...))])
|
||||
#'(if (or t* ...)
|
||||
(begin e e* ...)
|
||||
body))]))
|
||||
(syntax-case stx ()
|
||||
[(_ expr cls* ...)
|
||||
(with-syntax ([body (extract #'(cls* ...))])
|
||||
#'(let ([t expr])
|
||||
body))])))
|
||||
(define (mkseq e0 e1)
|
||||
;;; returns a (seq e0 e1) with a seq-less e1 if both
|
||||
;;; e0 and e1 are constructed properly.
|
||||
|
|
@ -88,13 +159,14 @@
|
|||
[(clambda) #t]
|
||||
[else #f]))
|
||||
;;; result returns the "last" value of an expression
|
||||
(define (result x)
|
||||
(define (result-expr x)
|
||||
(struct-case x
|
||||
[(seq e0 e1) e1]
|
||||
[else x]))
|
||||
(define (records-equal? x y)
|
||||
;;;
|
||||
(define (records-equal? x y ctxt)
|
||||
(struct-case x
|
||||
[(constant kx)
|
||||
[(constant kx)
|
||||
(struct-case y
|
||||
[(constant ky)
|
||||
(ctxt-case ctxt
|
||||
|
|
@ -103,27 +175,105 @@
|
|||
[else (eq? kx ky)])]
|
||||
[else #f])]
|
||||
[else #f]))
|
||||
(module (E-call)
|
||||
;;;
|
||||
(module (E-call value-visit-operand!)
|
||||
(define (residualize-operand x)
|
||||
(or (operand-value x)
|
||||
(E (operand-expr x) (operand-env x) 'e)))
|
||||
(define (residualize-operands e rand*)
|
||||
(cond
|
||||
[(null? rand*) e]
|
||||
[(not (rand-residualize-for-effect (car rand*)))
|
||||
[(not (operand-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*))))]))
|
||||
(mkseq
|
||||
(residualize-operand (car rand*))
|
||||
(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)
|
||||
(or (operand-value rand)
|
||||
(let ([e (E (operand-expr rand) (operand-env rand) 'v)])
|
||||
(set-operand-value! rand e)
|
||||
e)))
|
||||
(define (E-call rator rand* env ctxt)
|
||||
(let ([ctxt (make-app-ctxt rand* ctxt)])
|
||||
(let ([ctxt (make-app rand* ctxt)])
|
||||
(let ([rator (E rator env ctxt)])
|
||||
(if (app-inlined ctxt)
|
||||
(residualize-operand rator rand*)
|
||||
(if (app-inlined ctxt)
|
||||
(residualize-operands rator rand*)
|
||||
(make-funcall rator
|
||||
(map value-visit-operand! rand*)))))))
|
||||
;;;
|
||||
(define (E-var x env ctxt)
|
||||
(ctxt-case ctxt
|
||||
[(e) (make-constant (void))]
|
||||
[else
|
||||
(let ([x (lookup x env)])
|
||||
(let ([opnd (prelex-operand x)])
|
||||
(if opnd
|
||||
(begin
|
||||
(value-visit-operand! opnd)
|
||||
(if (prelex-source-assigned? x)
|
||||
(residualize-ref x)
|
||||
(copy x opnd ctxt)))
|
||||
(residualize-ref x))))]))
|
||||
;;;
|
||||
(define (copy x opnd ctxt)
|
||||
(let ([rhs (result-expr (operand-value opnd))])
|
||||
(struct-case rhs
|
||||
[(constant) rhs]
|
||||
[(var)
|
||||
(if (prelex-source-assigned? rhs)
|
||||
(residualize-ref x)
|
||||
(let ([opnd (prelex-operand rhs)])
|
||||
(if (and opnd (operand-value opnd))
|
||||
(copy2 rhs opnd ctxt)
|
||||
(residualize-ref rhs))))]
|
||||
[else (copy2 x opnd ctxt)])))
|
||||
(define (copy2 x opnd ctxt)
|
||||
(let ([rhs (result-expr (operand-value opnd))])
|
||||
(struct-case rhs
|
||||
[(clambda)
|
||||
(ctxt-case ctxt
|
||||
[(v) (residualize-ref x)]
|
||||
[(p) (make-constant #t)]
|
||||
[(e) (make-constant (void))]
|
||||
[(app) (inline rhs ctxt empty-env)]
|
||||
[else (error 'copy2 "cannot happen")])]
|
||||
[(primref p)
|
||||
(ctxt-case ctxt
|
||||
[(v) rhs]
|
||||
[(p) (make-constant #t)]
|
||||
[(e) (make-constant (void))]
|
||||
[(app) (fold-prim p ctxt)]
|
||||
[else (error 'copy2 "cannot happen")])]
|
||||
[else (residualize-ref x)])))
|
||||
;;;
|
||||
(define (inline proc ctxt env)
|
||||
(struct-case proc
|
||||
[(clambda g cases cp free name)
|
||||
(let ([rand* (app-rand* ctxt)])
|
||||
(struct-case (get-case cases rand*)
|
||||
[(clambda-case info body)
|
||||
(struct-case info
|
||||
[(case-info label args proper)
|
||||
(with-extended-env ((env args) (env args rand*))
|
||||
(let ([body (E body (app-ctxt ctxt) env)])
|
||||
(let ([result (make-let-binding args rand* body)])
|
||||
(set-app-inlined! ctxt #t)
|
||||
result)))])]
|
||||
[else proc]))]))
|
||||
;;;
|
||||
(define (make-let-binding args rand* body)
|
||||
(error 'make-let-binding "not yet"))
|
||||
(define (get-case . args)
|
||||
(error 'get-case "not yet"))
|
||||
;;;
|
||||
(define (fold-prim p ctxt)
|
||||
(make-primref p))
|
||||
;;;
|
||||
(define (residualize-ref x)
|
||||
(set-prelex-residual-referenced?! (var-info x) #t)
|
||||
x)
|
||||
;;;
|
||||
(define (E x env ctxt)
|
||||
(struct-case x
|
||||
[(constant) x]
|
||||
|
|
@ -132,7 +282,7 @@
|
|||
(mkseq (E e0 env 'e) (E e1 env ctxt))]
|
||||
[(conditional e0 e1 e2)
|
||||
(let ([e0 (E e0 env 'p)])
|
||||
(struct-case (result e0)
|
||||
(struct-case (result-expr e0)
|
||||
[(constant k)
|
||||
(mkseq e0 (E (if k e1 e2) env ctxt))]
|
||||
[else
|
||||
|
|
@ -146,23 +296,23 @@
|
|||
(mkseq
|
||||
(let ([xi (var-info x)])
|
||||
(cond
|
||||
[(not (info-source-referenced xi))
|
||||
[(not (prelex-source-referenced? xi))
|
||||
;;; dead on arrival
|
||||
(E v env 'e)]
|
||||
[else
|
||||
(set-info-residual-assigned! i #t)
|
||||
(set-prelex-residual-assigned?! xi #t)
|
||||
(make-assign x (E v env 'v))]))
|
||||
(make-constant (void)))]
|
||||
[(funcall rator rand*)
|
||||
(E-call rator (map (mkoperand env) rand*) env ctxt)]
|
||||
[(funcall rator rand*)
|
||||
(E-call rator (map (make-operand env) rand*) env ctxt)]
|
||||
[(primref name)
|
||||
(ctxt-case ctxt
|
||||
[(app) (E-fold-prim name env ctxt)]
|
||||
[(value) x]
|
||||
[(app) (fold-prim env ctxt)]
|
||||
[(v) x]
|
||||
[else (make-constant (void))])]
|
||||
[(clambda g cases cp free name)
|
||||
(ctxt-case ctxt
|
||||
[(app) (E-inline x env ctxt)]
|
||||
[(app) (inline x env ctxt)]
|
||||
[(p e) (make-constant (void))]
|
||||
[else
|
||||
(make-clambda g
|
||||
|
|
@ -174,14 +324,26 @@
|
|||
[(case-info label args proper)
|
||||
(with-extended-env ((env args) (env args #f))
|
||||
(make-clambda-case
|
||||
(make-info label args proper)
|
||||
(make-case-info label args proper)
|
||||
(E body env 'v)))])]))
|
||||
cases)
|
||||
cp free name)])]
|
||||
[else (error who "invalid expression" x)]))
|
||||
(define empty-env '())
|
||||
(define (lookup . args)
|
||||
(error 'lookup "not yet"))
|
||||
(define optimize-level
|
||||
(make-parameter #f))
|
||||
(define (source-optimize expr)
|
||||
(prepare expr)
|
||||
(E expr 'v)))
|
||||
(cond
|
||||
[(equal? (optimize-level) 17)
|
||||
(prepare expr)
|
||||
(pretty-print (unparse expr))
|
||||
(let ([expr (E expr empty-env 'v)])
|
||||
(pretty-print (unparse expr))
|
||||
expr)]
|
||||
[else expr])))
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@
|
|||
|
||||
|
||||
(library (ikarus.compiler)
|
||||
(export compile-core-expr-to-port
|
||||
(export compile-core-expr-to-port optimize-level
|
||||
assembler-output scc-letrec optimize-cp
|
||||
current-primitive-locations eval-core)
|
||||
(import
|
||||
|
|
@ -25,6 +25,7 @@
|
|||
(only (ikarus system $codes) $code->closure)
|
||||
(only (ikarus system $structs) $struct-ref $struct/rtd?)
|
||||
(except (ikarus)
|
||||
optimize-level
|
||||
fasl-write scc-letrec optimize-cp
|
||||
compile-core-expr-to-port assembler-output
|
||||
current-primitive-locations eval-core)
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
1385
|
||||
1387
|
||||
|
|
|
|||
|
|
@ -16,7 +16,8 @@
|
|||
|
||||
;;; vim:syntax=scheme
|
||||
(import (only (ikarus) import))
|
||||
(import (except (ikarus) assembler-output scc-letrec optimize-cp))
|
||||
(import (except (ikarus)
|
||||
optimize-level assembler-output scc-letrec optimize-cp))
|
||||
(import (ikarus.compiler))
|
||||
(import (except (psyntax system $bootstrap)
|
||||
eval-core
|
||||
|
|
@ -1395,6 +1396,7 @@
|
|||
[ellipsis-map ]
|
||||
[scc-letrec i]
|
||||
[optimize-cp i]
|
||||
[optimize-level i]
|
||||
))
|
||||
|
||||
(define (macro-identifier? x)
|
||||
|
|
|
|||
Loading…
Reference in New Issue