mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 05:50:26 +02:00
add tree-il optimizer
* module/language/tree-il/optimize.scm: New module, for optimizations. Currently all we have is resolving some toplevel refs to primitive refs. * module/Makefile.am: Add new module. * module/language/tree-il.scm: Fix exports for accessors for `src'. * module/language/tree-il/compile-glil.scm: Tweaks, things still aren't working yet.
This commit is contained in:
Andy Wingo
parent
b81d329e44
commit
9efc833d65
4 changed files with 221 additions and 327 deletions
|
|
@ -71,8 +71,10 @@ SCHEME_LANG_SOURCES = \
|
|||
language/scheme/decompile-tree-il.scm \
|
||||
language/scheme/inline.scm
|
||||
|
||||
TREE_IL_LANG_SOURCES = \
|
||||
language/tree-il/spec.scm language/tree-il/compile-glil.scm
|
||||
TREE_IL_LANG_SOURCES = \
|
||||
language/tree-il/spec.scm \
|
||||
language/tree-il/compile-glil.scm \
|
||||
language/tree-il/optimize.scm
|
||||
|
||||
GHIL_LANG_SOURCES = \
|
||||
language/ghil/spec.scm language/ghil/compile-glil.scm
|
||||
|
|
|
|||
|
|
@ -19,30 +19,30 @@
|
|||
(define-module (language tree-il)
|
||||
#:use-module (system base pmatch)
|
||||
#:use-module (system base syntax)
|
||||
:export (tree-il-loc
|
||||
#:export (tree-il-src
|
||||
|
||||
<lexical> make-lexical
|
||||
lexical-name lexical-gensym
|
||||
<lexical> make-lexical
|
||||
lexical-name lexical-gensym
|
||||
|
||||
<application> make-application application-loc application-proc application-args
|
||||
<conditional> make-conditional conditional-loc conditional-test conditional-then conditional-else
|
||||
<primitive-ref> make-primitive-ref primitive-ref-loc primitive-ref-name
|
||||
<lexical-ref> make-lexical-ref lexical-ref-loc lexical-ref-name lexical-ref-gensym
|
||||
<lexical-set> make-lexical-set lexical-set-loc lexical-set-name lexical-set-gensym lexical-set-exp
|
||||
<module-ref> make-module-ref module-ref-loc module-ref-mod module-ref-name module-ref-public?
|
||||
<module-set> make-module-set module-set-loc module-set-mod module-set-name module-set-public? module-set-exp
|
||||
<toplevel-ref> make-toplevel-ref toplevel-ref-loc toplevel-ref-name
|
||||
<toplevel-set> make-toplevel-set toplevel-set-loc toplevel-set-name toplevel-set-exp
|
||||
<toplevel-define> make-toplevel-define toplevel-define-loc toplevel-define-name toplevel-define-exp
|
||||
<lambda> make-lambda lambda-loc lambda-vars lambda-meta lambda-body
|
||||
<const> make-const const-loc const-exp
|
||||
<sequence> make-sequence sequence-loc sequence-exps
|
||||
<let> make-let let-loc let-vars let-vals let-exp
|
||||
<letrec> make-letrec letrec-loc letrec-vars letrec-vals letrec-exp
|
||||
<application> make-application application-src application-proc application-args
|
||||
<conditional> make-conditional conditional-src conditional-test conditional-then conditional-else
|
||||
<primitive-ref> make-primitive-ref primitive-ref-src primitive-ref-name
|
||||
<lexical-ref> make-lexical-ref lexical-ref-src lexical-ref-name lexical-ref-gensym
|
||||
<lexical-set> make-lexical-set lexical-set-src lexical-set-name lexical-set-gensym lexical-set-exp
|
||||
<module-ref> make-module-ref module-ref-src module-ref-mod module-ref-name module-ref-public?
|
||||
<module-set> make-module-set module-set-src module-set-mod module-set-name module-set-public? module-set-exp
|
||||
<toplevel-ref> make-toplevel-ref toplevel-ref-src toplevel-ref-name
|
||||
<toplevel-set> make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp
|
||||
<toplevel-define> make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp
|
||||
<lambda> make-lambda lambda-src lambda-vars lambda-meta lambda-body
|
||||
<const> make-const const-src const-exp
|
||||
<sequence> make-sequence sequence-src sequence-exps
|
||||
<let> make-let let-src let-vars let-vals let-exp
|
||||
<letrec> make-letrec letrec-src letrec-vars letrec-vals letrec-exp
|
||||
|
||||
parse-tree-il
|
||||
unparse-tree-il
|
||||
tree-il->scheme))
|
||||
parse-tree-il
|
||||
unparse-tree-il
|
||||
tree-il->scheme))
|
||||
|
||||
(define-type (<tree-il> #:common-slots (src))
|
||||
(<application> proc args)
|
||||
|
|
|
|||
|
|
@ -27,168 +27,11 @@
|
|||
#:export (compile-glil))
|
||||
|
||||
(define (compile-glil x e opts)
|
||||
(if (memq #:O opts) (set! x (optimize x)))
|
||||
(values (codegen x)
|
||||
(and e (cons (car e) (cddr e)))
|
||||
e))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Stage 2: Optimization
|
||||
;;;
|
||||
|
||||
(define (lift-variables! env)
|
||||
(let ((parent-env (ghil-env-parent env)))
|
||||
(for-each (lambda (v)
|
||||
(case (ghil-var-kind v)
|
||||
((argument) (set! (ghil-var-kind v) 'local)))
|
||||
(set! (ghil-var-env v) parent-env)
|
||||
(ghil-env-add! parent-env v))
|
||||
(ghil-env-variables env))))
|
||||
|
||||
;; Possible optimizations:
|
||||
;; * compile primitives specially
|
||||
;; * turn global-refs into primitive-refs
|
||||
;; * constant folding, propagation
|
||||
;; * procedure inlining
|
||||
;; * always when single call site
|
||||
;; * always for "trivial" procs
|
||||
;; * otherwise who knows
|
||||
;; * dead code elimination
|
||||
;; * degenerate case optimizations
|
||||
|
||||
|
||||
;; The premise of this, unused, approach to optimization is that you can
|
||||
;; determine the environment of a variable lexically, because they have
|
||||
;; been alpha-renamed. It makes the transformations *much* easier.
|
||||
;; Unfortunately it doesn't work yet.
|
||||
(define (optimize* x)
|
||||
(transform-record (<ghil> env loc) x
|
||||
((quasiquote exp)
|
||||
(define (optimize-qq x)
|
||||
(cond ((list? x) (map optimize-qq x))
|
||||
((pair? x) (cons (optimize-qq (car x)) (optimize-qq (cdr x))))
|
||||
((record? x) (optimize x))
|
||||
(else x)))
|
||||
(-> (quasiquote (optimize-qq x))))
|
||||
|
||||
((unquote exp)
|
||||
(-> (unquote (optimize exp))))
|
||||
|
||||
((unquote-splicing exp)
|
||||
(-> (unquote-splicing (optimize exp))))
|
||||
|
||||
((set var val)
|
||||
(-> (set var (optimize val))))
|
||||
|
||||
((define var val)
|
||||
(-> (define var (optimize val))))
|
||||
|
||||
((if test then else)
|
||||
(-> (if (optimize test) (optimize then) (optimize else))))
|
||||
|
||||
((and exps)
|
||||
(-> (and (map optimize exps))))
|
||||
|
||||
((or exps)
|
||||
(-> (or (map optimize exps))))
|
||||
|
||||
((begin exps)
|
||||
(-> (begin (map optimize exps))))
|
||||
|
||||
((bind vars vals body)
|
||||
(-> (bind vars (map optimize vals) (optimize body))))
|
||||
|
||||
((mv-bind producer vars rest body)
|
||||
(-> (mv-bind (optimize producer) vars rest (optimize body))))
|
||||
|
||||
((inline inst args)
|
||||
(-> (inline inst (map optimize args))))
|
||||
|
||||
((call (proc (lambda vars (rest #f) meta body)) args)
|
||||
(-> (bind vars (optimize args) (optimize body))))
|
||||
|
||||
((call proc args)
|
||||
(-> (call (optimize proc) (map optimize args))))
|
||||
|
||||
((lambda vars rest meta body)
|
||||
(-> (lambda vars rest meta (optimize body))))
|
||||
|
||||
((mv-call producer (consumer (lambda vars rest meta body)))
|
||||
(-> (mv-bind (optimize producer) vars rest (optimize body))))
|
||||
|
||||
((mv-call producer consumer)
|
||||
(-> (mv-call (optimize producer) (optimize consumer))))
|
||||
|
||||
((values values)
|
||||
(-> (values (map optimize values))))
|
||||
|
||||
((values* values)
|
||||
(-> (values* (map optimize values))))
|
||||
|
||||
(else
|
||||
(error "unrecognized GHIL" x))))
|
||||
|
||||
(define (optimize x)
|
||||
(record-case x
|
||||
((<ghil-set> env loc var val)
|
||||
(make-ghil-set env var (optimize val)))
|
||||
|
||||
((<ghil-define> env loc var val)
|
||||
(make-ghil-define env var (optimize val)))
|
||||
|
||||
((<ghil-if> env loc test then else)
|
||||
(make-ghil-if env loc (optimize test) (optimize then) (optimize else)))
|
||||
|
||||
((<ghil-and> env loc exps)
|
||||
(make-ghil-and env loc (map optimize exps)))
|
||||
|
||||
((<ghil-or> env loc exps)
|
||||
(make-ghil-or env loc (map optimize exps)))
|
||||
|
||||
((<ghil-begin> env loc exps)
|
||||
(make-ghil-begin env loc (map optimize exps)))
|
||||
|
||||
((<ghil-bind> env loc vars vals body)
|
||||
(make-ghil-bind env loc vars (map optimize vals) (optimize body)))
|
||||
|
||||
((<ghil-lambda> env loc vars rest meta body)
|
||||
(make-ghil-lambda env loc vars rest meta (optimize body)))
|
||||
|
||||
((<ghil-inline> env loc instruction args)
|
||||
(make-ghil-inline env loc instruction (map optimize args)))
|
||||
|
||||
((<ghil-call> env loc proc args)
|
||||
(let ((parent-env env))
|
||||
(record-case proc
|
||||
;; ((@lambda (VAR...) BODY...) ARG...) =>
|
||||
;; (@let ((VAR ARG) ...) BODY...)
|
||||
((<ghil-lambda> env loc vars rest meta body)
|
||||
(cond
|
||||
((not rest)
|
||||
(lift-variables! env)
|
||||
(make-ghil-bind parent-env loc (map optimize args)))
|
||||
(else
|
||||
(make-ghil-call parent-env loc (optimize proc) (map optimize args)))))
|
||||
(else
|
||||
(make-ghil-call parent-env loc (optimize proc) (map optimize args))))))
|
||||
|
||||
((<ghil-mv-call> env loc producer consumer)
|
||||
(record-case consumer
|
||||
;; (mv-call PRODUCER (lambda ARGS BODY...)) =>
|
||||
;; (mv-let PRODUCER ARGS BODY...)
|
||||
((<ghil-lambda> env loc vars rest meta body)
|
||||
(lift-variables! env)
|
||||
(make-ghil-mv-bind producer vars rest body))
|
||||
(else
|
||||
(make-ghil-mv-call env loc (optimize producer) (optimize consumer)))))
|
||||
|
||||
(else x)))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Stage 3: Code generation
|
||||
;;;
|
||||
|
||||
(define *ia-void* (make-glil-void))
|
||||
(define *ia-drop* (make-glil-call 'drop 1))
|
||||
|
|
@ -214,33 +57,24 @@
|
|||
(eq? (ghil-var-kind var) 'public)))
|
||||
(else (error "Unknown kind of variable:" var))))
|
||||
|
||||
(define (constant? x)
|
||||
(cond ((or (number? x) (string? x) (symbol? x) (keyword? x) (boolean? x)) #t)
|
||||
((pair? x) (and (constant? (car x))
|
||||
(constant? (cdr x))))
|
||||
((vector? x) (let lp ((i (vector-length x)))
|
||||
(or (zero? i)
|
||||
(and (constant? (vector-ref x (1- i)))
|
||||
(lp (1- i))))))))
|
||||
|
||||
(define (codegen ghil)
|
||||
(let ((stack '()))
|
||||
(define (push-code! loc code)
|
||||
(define (push-code! src code)
|
||||
(set! stack (cons code stack))
|
||||
(if loc (set! stack (cons (make-glil-source loc) stack))))
|
||||
(if src (set! stack (cons (make-glil-source src) stack))))
|
||||
(define (var->binding var)
|
||||
(list (ghil-var-name var) (ghil-var-kind var) (ghil-var-index var)))
|
||||
(define (push-bindings! loc vars)
|
||||
(define (push-bindings! src vars)
|
||||
(if (not (null? vars))
|
||||
(push-code! loc (make-glil-bind (map var->binding vars)))))
|
||||
(push-code! src (make-glil-bind (map var->binding vars)))))
|
||||
(define (comp tree tail drop)
|
||||
(define (push-label! label)
|
||||
(push-code! #f (make-glil-label label)))
|
||||
(define (push-branch! loc inst label)
|
||||
(push-code! loc (make-glil-branch inst label)))
|
||||
(define (push-call! loc inst args)
|
||||
(define (push-branch! src inst label)
|
||||
(push-code! src (make-glil-branch inst label)))
|
||||
(define (push-call! src inst args)
|
||||
(for-each comp-push args)
|
||||
(push-code! loc (make-glil-call inst (length args))))
|
||||
(push-code! src (make-glil-call inst (length args))))
|
||||
;; possible tail position
|
||||
(define (comp-tail tree) (comp tree tail drop))
|
||||
;; push the result
|
||||
|
|
@ -254,72 +88,38 @@
|
|||
(define (maybe-return)
|
||||
(if tail (push-code! #f *ia-return*)))
|
||||
;; return this code if necessary
|
||||
(define (return-code! loc code)
|
||||
(if (not drop) (push-code! loc code))
|
||||
(define (return-code! src code)
|
||||
(if (not drop) (push-code! src code))
|
||||
(maybe-return))
|
||||
;; return void if necessary
|
||||
(define (return-void!)
|
||||
(return-code! #f *ia-void*))
|
||||
;; return object if necessary
|
||||
(define (return-object! loc obj)
|
||||
(return-code! loc (make-glil-const obj)))
|
||||
(define (return-object! src obj)
|
||||
(return-code! src (make-glil-const obj)))
|
||||
;;
|
||||
;; dispatch
|
||||
(record-case tree
|
||||
((<ghil-void>)
|
||||
(return-void!))
|
||||
|
||||
((<ghil-quote> env loc obj)
|
||||
(return-object! loc obj))
|
||||
((<ghil-quote> env src obj)
|
||||
(return-object! src obj))
|
||||
|
||||
((<ghil-quasiquote> env loc exp)
|
||||
(let loop ((x exp) (in-car? #f))
|
||||
(cond
|
||||
((list? x)
|
||||
(push-call! #f 'mark '())
|
||||
(for-each (lambda (x) (loop x #t)) x)
|
||||
(push-call! #f 'list-mark '()))
|
||||
((pair? x)
|
||||
(push-call! #f 'mark '())
|
||||
(loop (car x) #t)
|
||||
(loop (cdr x) #f)
|
||||
(push-call! #f 'cons-mark '()))
|
||||
((record? x)
|
||||
(record-case x
|
||||
((<ghil-unquote> env loc exp)
|
||||
(comp-push exp))
|
||||
((<ghil-unquote-splicing> env loc exp)
|
||||
(if (not in-car?)
|
||||
(error "unquote-splicing in the cdr of a pair" exp))
|
||||
(comp-push exp)
|
||||
(push-call! #f 'list-break '()))))
|
||||
((constant? x)
|
||||
(push-code! #f (make-glil-const x)))
|
||||
(else
|
||||
(error "element of quasiquote can't be compiled" x))))
|
||||
(maybe-drop)
|
||||
(maybe-return))
|
||||
((<ghil-ref> env src var)
|
||||
(return-code! src (make-glil-var 'ref env var)))
|
||||
|
||||
((<ghil-unquote> env loc exp)
|
||||
(error "unquote outside of quasiquote" exp))
|
||||
|
||||
((<ghil-unquote-splicing> env loc exp)
|
||||
(error "unquote-splicing outside of quasiquote" exp))
|
||||
|
||||
((<ghil-ref> env loc var)
|
||||
(return-code! loc (make-glil-var 'ref env var)))
|
||||
|
||||
((<ghil-set> env loc var val)
|
||||
((<ghil-set> env src var val)
|
||||
(comp-push val)
|
||||
(push-code! loc (make-glil-var 'set env var))
|
||||
(push-code! src (make-glil-var 'set env var))
|
||||
(return-void!))
|
||||
|
||||
((<ghil-define> env loc var val)
|
||||
(comp-push val)
|
||||
(push-code! loc (make-glil-var 'define env var))
|
||||
((<toplevel-define> src name exp)
|
||||
(comp-push exp)
|
||||
(push-code! src (make-glil-var 'define env var))
|
||||
(return-void!))
|
||||
|
||||
((<ghil-if> env loc test then else)
|
||||
((<conditional> src test then else)
|
||||
;; TEST
|
||||
;; (br-if-not L1)
|
||||
;; THEN
|
||||
|
|
@ -328,65 +128,14 @@
|
|||
;; L2:
|
||||
(let ((L1 (make-label)) (L2 (make-label)))
|
||||
(comp-push test)
|
||||
(push-branch! loc 'br-if-not L1)
|
||||
(push-branch! src 'br-if-not L1)
|
||||
(comp-tail then)
|
||||
(if (not tail) (push-branch! #f 'br L2))
|
||||
(push-label! L1)
|
||||
(comp-tail else)
|
||||
(if (not tail) (push-label! L2))))
|
||||
|
||||
((<ghil-and> env loc exps)
|
||||
;; EXP
|
||||
;; (br-if-not L1)
|
||||
;; ...
|
||||
;; TAIL
|
||||
;; (br L2)
|
||||
;; L1: (const #f)
|
||||
;; L2:
|
||||
(cond ((null? exps) (return-object! loc #t))
|
||||
((null? (cdr exps)) (comp-tail (car exps)))
|
||||
(else
|
||||
(let ((L1 (make-label)) (L2 (make-label)))
|
||||
(let lp ((exps exps))
|
||||
(cond ((null? (cdr exps))
|
||||
(comp-tail (car exps))
|
||||
(push-branch! #f 'br L2)
|
||||
(push-label! L1)
|
||||
(return-object! #f #f)
|
||||
(push-label! L2)
|
||||
(maybe-return))
|
||||
(else
|
||||
(comp-push (car exps))
|
||||
(push-branch! #f 'br-if-not L1)
|
||||
(lp (cdr exps)))))))))
|
||||
|
||||
((<ghil-or> env loc exps)
|
||||
;; EXP
|
||||
;; (dup)
|
||||
;; (br-if L1)
|
||||
;; (drop)
|
||||
;; ...
|
||||
;; TAIL
|
||||
;; L1:
|
||||
(cond ((null? exps) (return-object! loc #f))
|
||||
((null? (cdr exps)) (comp-tail (car exps)))
|
||||
(else
|
||||
(let ((L1 (make-label)))
|
||||
(let lp ((exps exps))
|
||||
(cond ((null? (cdr exps))
|
||||
(comp-tail (car exps))
|
||||
(push-label! L1)
|
||||
(maybe-return))
|
||||
(else
|
||||
(comp-push (car exps))
|
||||
(if (not drop)
|
||||
(push-call! #f 'dup '()))
|
||||
(push-branch! #f 'br-if L1)
|
||||
(if (not drop)
|
||||
(push-code! loc (make-glil-call 'drop 1)))
|
||||
(lp (cdr exps)))))))))
|
||||
|
||||
((<ghil-begin> env loc exps)
|
||||
((<sequence> src exps)
|
||||
;; EXPS...
|
||||
;; TAIL
|
||||
(if (null? exps)
|
||||
|
|
@ -396,24 +145,24 @@
|
|||
(comp-tail (car exps)))
|
||||
(comp-drop (car exps)))))
|
||||
|
||||
((<ghil-bind> env loc vars vals body)
|
||||
((<let> src vars vals body)
|
||||
;; VALS...
|
||||
;; (set VARS)...
|
||||
;; BODY
|
||||
(for-each comp-push vals)
|
||||
(push-bindings! loc vars)
|
||||
(push-bindings! src vars)
|
||||
(for-each (lambda (var) (push-code! #f (make-glil-var 'set env var)))
|
||||
(reverse vars))
|
||||
(comp-tail body)
|
||||
(push-code! #f (make-glil-unbind)))
|
||||
|
||||
((<ghil-mv-bind> env loc producer vars rest body)
|
||||
((<ghil-mv-bind> env src producer vars rest body)
|
||||
;; VALS...
|
||||
;; (set VARS)...
|
||||
;; BODY
|
||||
(let ((MV (make-label)))
|
||||
(comp-push producer)
|
||||
(push-code! loc (make-glil-mv-call 0 MV))
|
||||
(push-code! src (make-glil-mv-call 0 MV))
|
||||
(push-code! #f (make-glil-const 1))
|
||||
(push-label! MV)
|
||||
(push-code! #f (make-glil-mv-bind (map var->binding vars) rest))
|
||||
|
|
@ -422,10 +171,10 @@
|
|||
(comp-tail body)
|
||||
(push-code! #f (make-glil-unbind)))
|
||||
|
||||
((<ghil-lambda> env loc vars rest meta body)
|
||||
(return-code! loc (codegen tree)))
|
||||
((<ghil-lambda> env src vars rest meta body)
|
||||
(return-code! src (codegen tree)))
|
||||
|
||||
((<ghil-inline> env loc inline args)
|
||||
((<ghil-inline> env src inline args)
|
||||
;; ARGS...
|
||||
;; (INST NARGS)
|
||||
(let ((tail-table '((call . goto/args)
|
||||
|
|
@ -433,50 +182,50 @@
|
|||
(call/cc . goto/cc))))
|
||||
(cond ((and tail (assq-ref tail-table inline))
|
||||
=> (lambda (tail-inst)
|
||||
(push-call! loc tail-inst args)))
|
||||
(push-call! src tail-inst args)))
|
||||
(else
|
||||
(push-call! loc inline args)
|
||||
(push-call! src inline args)
|
||||
(maybe-drop)
|
||||
(maybe-return)))))
|
||||
|
||||
((<ghil-values> env loc values)
|
||||
((<ghil-values> env src values)
|
||||
(cond (tail ;; (lambda () (values 1 2))
|
||||
(push-call! loc 'return/values values))
|
||||
(push-call! src 'return/values values))
|
||||
(drop ;; (lambda () (values 1 2) 3)
|
||||
(for-each comp-drop values))
|
||||
(else ;; (lambda () (list (values 10 12) 1))
|
||||
(push-code! #f (make-glil-const 'values))
|
||||
(push-code! #f (make-glil-call 'link-now 1))
|
||||
(push-code! #f (make-glil-call 'variable-ref 0))
|
||||
(push-call! loc 'call values))))
|
||||
(push-call! src 'call values))))
|
||||
|
||||
((<ghil-values*> env loc values)
|
||||
((<ghil-values*> env src values)
|
||||
(cond (tail ;; (lambda () (apply values '(1 2)))
|
||||
(push-call! loc 'return/values* values))
|
||||
(push-call! src 'return/values* values))
|
||||
(drop ;; (lambda () (apply values '(1 2)) 3)
|
||||
(for-each comp-drop values))
|
||||
(else ;; (lambda () (list (apply values '(10 12)) 1))
|
||||
(push-code! #f (make-glil-const 'values))
|
||||
(push-code! #f (make-glil-call 'link-now 1))
|
||||
(push-code! #f (make-glil-call 'variable-ref 0))
|
||||
(push-call! loc 'apply values))))
|
||||
(push-call! src 'apply values))))
|
||||
|
||||
((<ghil-call> env loc proc args)
|
||||
((<ghil-call> env src proc args)
|
||||
;; PROC
|
||||
;; ARGS...
|
||||
;; ([tail-]call NARGS)
|
||||
(comp-push proc)
|
||||
(let ((nargs (length args)))
|
||||
(cond ((< nargs 255)
|
||||
(push-call! loc (if tail 'goto/args 'call) args))
|
||||
(push-call! src (if tail 'goto/args 'call) args))
|
||||
(else
|
||||
(push-call! loc 'mark '())
|
||||
(push-call! src 'mark '())
|
||||
(for-each comp-push args)
|
||||
(push-call! loc 'list-mark '())
|
||||
(push-code! loc (make-glil-call (if tail 'goto/apply 'apply) 2)))))
|
||||
(push-call! src 'list-mark '())
|
||||
(push-code! src (make-glil-call (if tail 'goto/apply 'apply) 2)))))
|
||||
(maybe-drop))
|
||||
|
||||
((<ghil-mv-call> env loc producer consumer)
|
||||
((<ghil-mv-call> env src producer consumer)
|
||||
;; CONSUMER
|
||||
;; PRODUCER
|
||||
;; (mv-call MV)
|
||||
|
|
@ -487,25 +236,25 @@
|
|||
(let ((MV (make-label)) (POST (make-label)))
|
||||
(comp-push consumer)
|
||||
(comp-push producer)
|
||||
(push-code! loc (make-glil-mv-call 0 MV))
|
||||
(push-code! loc (make-glil-call (if tail 'goto/args 'call) 1))
|
||||
(push-code! src (make-glil-mv-call 0 MV))
|
||||
(push-code! src (make-glil-call (if tail 'goto/args 'call) 1))
|
||||
(cond ((not tail)
|
||||
(push-branch! #f 'br POST)))
|
||||
(push-label! MV)
|
||||
(push-code! loc (make-glil-call (if tail 'goto/nargs 'call/nargs) 0))
|
||||
(push-code! src (make-glil-call (if tail 'goto/nargs 'call/nargs) 0))
|
||||
(cond ((not tail)
|
||||
(push-label! POST)
|
||||
(maybe-drop)))))
|
||||
|
||||
((<ghil-reified-env> env loc)
|
||||
(return-object! loc (ghil-env-reify env)))))
|
||||
((<ghil-reified-env> env src)
|
||||
(return-object! src (ghil-env-reify env)))))
|
||||
|
||||
;;
|
||||
;; main
|
||||
(record-case ghil
|
||||
((<ghil-lambda> env loc vars rest meta body)
|
||||
((<ghil-lambda> env src vars rest meta body)
|
||||
(let* ((evars (ghil-env-variables env))
|
||||
(locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars))
|
||||
(srcs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars))
|
||||
(exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars))
|
||||
(nargs (allocate-indices-linearly! vars))
|
||||
(nlocs (allocate-locals! locs body))
|
||||
|
|
@ -513,7 +262,7 @@
|
|||
;; meta bindings
|
||||
(push-bindings! #f vars)
|
||||
;; push on definition source location
|
||||
(if loc (set! stack (cons (make-glil-source loc) stack)))
|
||||
(if src (set! stack (cons (make-glil-source src) stack)))
|
||||
;; copy args to the heap if they're marked as external
|
||||
(do ((n 0 (1+ n))
|
||||
(l vars (cdr l)))
|
||||
|
|
|
|||
143
module/language/tree-il/optimize.scm
Normal file
143
module/language/tree-il/optimize.scm
Normal file
|
|
@ -0,0 +1,143 @@
|
|||
;;; Tree-il optimizer
|
||||
|
||||
;; Copyright (C) 2009 Free Software Foundation, Inc.
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation; either version 2, or (at your option)
|
||||
;; any later version.
|
||||
;;
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program; see the file COPYING. If not, write to
|
||||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
;; Boston, MA 02111-1307, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(define-module (language tree-il optimize)
|
||||
#:use-module (system base syntax)
|
||||
#:use-module (language tree-il)
|
||||
#:export (resolve-primitives!))
|
||||
|
||||
;; Possible optimizations:
|
||||
;; * constant folding, propagation
|
||||
;; * procedure inlining
|
||||
;; * always when single call site
|
||||
;; * always for "trivial" procs
|
||||
;; * otherwise who knows
|
||||
;; * dead code elimination
|
||||
;; * degenerate case optimizations
|
||||
;; * "fixing letrec"
|
||||
|
||||
(define (post-order! f x)
|
||||
(let lp ((x x))
|
||||
(record-case x
|
||||
((<application> proc args)
|
||||
(set! (application-proc x) (lp proc))
|
||||
(set! (application-args x) (map lp args))
|
||||
(or (f x) x))
|
||||
|
||||
((<conditional> test then else)
|
||||
(set! (conditional-test x) (lp test))
|
||||
(set! (conditional-then x) (lp then))
|
||||
(set! (conditional-else x) (lp else))
|
||||
(or (f x) x))
|
||||
|
||||
((<primitive-ref> name)
|
||||
(or (f x) x))
|
||||
|
||||
((<lexical-ref> name gensym)
|
||||
(or (f x) x))
|
||||
|
||||
((<lexical-set> name gensym exp)
|
||||
(set! (lexical-set-exp x) (lp exp))
|
||||
(or (f x) x))
|
||||
|
||||
((<module-ref> mod name public?)
|
||||
(or (f x) x))
|
||||
|
||||
((<module-set> mod name public? exp)
|
||||
(set! (module-set-exp x) (lp exp))
|
||||
(or (f x) x))
|
||||
|
||||
((<toplevel-ref> name)
|
||||
(or (f x) x))
|
||||
|
||||
((<toplevel-set> name exp)
|
||||
(set! (toplevel-set-exp x) (lp exp))
|
||||
(or (f x) x))
|
||||
|
||||
((<toplevel-define> name exp)
|
||||
(set! (toplevel-define-exp x) (lp exp))
|
||||
(or (f x) x))
|
||||
|
||||
((<lambda> vars meta body)
|
||||
(set! (lambda-body x) (lp body))
|
||||
(or (f x) x))
|
||||
|
||||
((<const> exp)
|
||||
(or (f x) x))
|
||||
|
||||
((<sequence> exps)
|
||||
(set! (sequence-exps x) (map lp exps))
|
||||
(or (f x) x))
|
||||
|
||||
((<let> vars vals exp)
|
||||
(set! (let-vals x) (map lp vals))
|
||||
(set! (let-exp x) (lp exp))
|
||||
(or (f x) x))
|
||||
|
||||
((<letrec> vars vals exp)
|
||||
(set! (letrec-vals x) (map lp vals))
|
||||
(set! (letrec-exp x) (lp exp))
|
||||
(or (f x) x)))))
|
||||
|
||||
(define *interesting-primitive-names*
|
||||
'(apply @apply
|
||||
call-with-values @call-with-values
|
||||
call-with-current-continuation @call-with-current-continuation
|
||||
values
|
||||
;; compile-time-environment
|
||||
eq? eqv? equal?
|
||||
= < > <= >= zero?
|
||||
+ * - / 1- 1+ quotient remainder modulo
|
||||
not
|
||||
pair? null? list? acons cons cons*
|
||||
|
||||
car cdr
|
||||
set-car! set-cdr!
|
||||
|
||||
caar cadr cdar cddr
|
||||
|
||||
caaar caadr cadar caddr cdaar cdadr cddar cdddr
|
||||
|
||||
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
|
||||
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr))
|
||||
|
||||
(define *interesting-primitive-vars*
|
||||
(let ((h (make-hash-table)))
|
||||
(for-each (lambda (x)
|
||||
(hashq-set! h (module-variable the-root-module x) x))
|
||||
*interesting-primitive-names*)
|
||||
h))
|
||||
|
||||
(define (resolve-primitives! x mod)
|
||||
(post-order!
|
||||
(lambda (x)
|
||||
(record-case x
|
||||
((<toplevel-ref> src name)
|
||||
(and (hashq-ref *interesting-primitive-vars*
|
||||
(module-variable mod name))
|
||||
(make-primitive-ref src name)))
|
||||
((<module-ref> mod name public?)
|
||||
(let ((m (if public? (resolve-interface mod) (resolve-module mod))))
|
||||
(and m (hashq-ref *interesting-primitive-vars*
|
||||
(module-variable m name))
|
||||
(make-primitive-ref src name))))
|
||||
(else #f)))
|
||||
x))
|
||||
Loading…
Add table
Add a link
Reference in a new issue