diff --git a/module/Makefile.am b/module/Makefile.am index ffe159ce9..3f607f259 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -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 diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index fa655d815..3de73b9c0 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.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 - make-lexical - lexical-name lexical-gensym + make-lexical + lexical-name lexical-gensym - make-application application-loc application-proc application-args - make-conditional conditional-loc conditional-test conditional-then conditional-else - make-primitive-ref primitive-ref-loc primitive-ref-name - make-lexical-ref lexical-ref-loc lexical-ref-name lexical-ref-gensym - make-lexical-set lexical-set-loc lexical-set-name lexical-set-gensym lexical-set-exp - make-module-ref module-ref-loc module-ref-mod module-ref-name module-ref-public? - make-module-set module-set-loc module-set-mod module-set-name module-set-public? module-set-exp - make-toplevel-ref toplevel-ref-loc toplevel-ref-name - make-toplevel-set toplevel-set-loc toplevel-set-name toplevel-set-exp - make-toplevel-define toplevel-define-loc toplevel-define-name toplevel-define-exp - make-lambda lambda-loc lambda-vars lambda-meta lambda-body - make-const const-loc const-exp - make-sequence sequence-loc sequence-exps - make-let let-loc let-vars let-vals let-exp - make-letrec letrec-loc letrec-vars letrec-vals letrec-exp + make-application application-src application-proc application-args + make-conditional conditional-src conditional-test conditional-then conditional-else + make-primitive-ref primitive-ref-src primitive-ref-name + make-lexical-ref lexical-ref-src lexical-ref-name lexical-ref-gensym + make-lexical-set lexical-set-src lexical-set-name lexical-set-gensym lexical-set-exp + make-module-ref module-ref-src module-ref-mod module-ref-name module-ref-public? + make-module-set module-set-src module-set-mod module-set-name module-set-public? module-set-exp + make-toplevel-ref toplevel-ref-src toplevel-ref-name + make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp + make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp + make-lambda lambda-src lambda-vars lambda-meta lambda-body + make-const const-src const-exp + make-sequence sequence-src sequence-exps + make-let let-src let-vars let-vals let-exp + 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 ( #:common-slots (src)) ( proc args) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index dbe4b25ef..d75ae7a56 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -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 ( 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 - (( env loc var val) - (make-ghil-set env var (optimize val))) - - (( env loc var val) - (make-ghil-define env var (optimize val))) - - (( env loc test then else) - (make-ghil-if env loc (optimize test) (optimize then) (optimize else))) - - (( env loc exps) - (make-ghil-and env loc (map optimize exps))) - - (( env loc exps) - (make-ghil-or env loc (map optimize exps))) - - (( env loc exps) - (make-ghil-begin env loc (map optimize exps))) - - (( env loc vars vals body) - (make-ghil-bind env loc vars (map optimize vals) (optimize body))) - - (( env loc vars rest meta body) - (make-ghil-lambda env loc vars rest meta (optimize body))) - - (( env loc instruction args) - (make-ghil-inline env loc instruction (map optimize args))) - - (( env loc proc args) - (let ((parent-env env)) - (record-case proc - ;; ((@lambda (VAR...) BODY...) ARG...) => - ;; (@let ((VAR ARG) ...) BODY...) - (( 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)))))) - - (( env loc producer consumer) - (record-case consumer - ;; (mv-call PRODUCER (lambda ARGS BODY...)) => - ;; (mv-let PRODUCER ARGS BODY...) - (( 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 (() (return-void!)) - (( env loc obj) - (return-object! loc obj)) + (( env src obj) + (return-object! src obj)) - (( 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 - (( env loc exp) - (comp-push exp)) - (( 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)) + (( env src var) + (return-code! src (make-glil-var 'ref env var))) - (( env loc exp) - (error "unquote outside of quasiquote" exp)) - - (( env loc exp) - (error "unquote-splicing outside of quasiquote" exp)) - - (( env loc var) - (return-code! loc (make-glil-var 'ref env var))) - - (( env loc var val) + (( 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!)) - (( env loc var val) - (comp-push val) - (push-code! loc (make-glil-var 'define env var)) + (( src name exp) + (comp-push exp) + (push-code! src (make-glil-var 'define env var)) (return-void!)) - (( env loc test then else) + (( 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)))) - (( 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))))))))) - - (( 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))))))))) - - (( env loc exps) + (( src exps) ;; EXPS... ;; TAIL (if (null? exps) @@ -396,24 +145,24 @@ (comp-tail (car exps))) (comp-drop (car exps))))) - (( env loc vars vals body) + (( 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))) - (( env loc producer vars rest body) + (( 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))) - (( env loc vars rest meta body) - (return-code! loc (codegen tree))) + (( env src vars rest meta body) + (return-code! src (codegen tree))) - (( env loc inline args) + (( 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))))) - (( env loc 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)))) - (( env loc 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)))) - (( env loc proc args) + (( 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)) - (( env loc producer consumer) + (( 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))))) - (( env loc) - (return-object! loc (ghil-env-reify env))))) + (( env src) + (return-object! src (ghil-env-reify env))))) ;; ;; main (record-case ghil - (( env loc vars rest meta body) + (( 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))) diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm new file mode 100644 index 000000000..69aff6f78 --- /dev/null +++ b/module/language/tree-il/optimize.scm @@ -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 + (( proc args) + (set! (application-proc x) (lp proc)) + (set! (application-args x) (map lp args)) + (or (f x) x)) + + (( 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)) + + (( name) + (or (f x) x)) + + (( name gensym) + (or (f x) x)) + + (( name gensym exp) + (set! (lexical-set-exp x) (lp exp)) + (or (f x) x)) + + (( mod name public?) + (or (f x) x)) + + (( mod name public? exp) + (set! (module-set-exp x) (lp exp)) + (or (f x) x)) + + (( name) + (or (f x) x)) + + (( name exp) + (set! (toplevel-set-exp x) (lp exp)) + (or (f x) x)) + + (( name exp) + (set! (toplevel-define-exp x) (lp exp)) + (or (f x) x)) + + (( vars meta body) + (set! (lambda-body x) (lp body)) + (or (f x) x)) + + (( exp) + (or (f x) x)) + + (( exps) + (set! (sequence-exps x) (map lp exps)) + (or (f x) x)) + + (( vars vals exp) + (set! (let-vals x) (map lp vals)) + (set! (let-exp x) (lp exp)) + (or (f x) x)) + + (( 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 + (( src name) + (and (hashq-ref *interesting-primitive-vars* + (module-variable mod name)) + (make-primitive-ref src name))) + (( 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))