summaryrefslogtreecommitdiff
path: root/module/language/tree-il/compile-glil.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/language/tree-il/compile-glil.scm')
-rw-r--r--module/language/tree-il/compile-glil.scm591
1 files changed, 591 insertions, 0 deletions
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
new file mode 100644
index 000000000..3a0225577
--- /dev/null
+++ b/module/language/tree-il/compile-glil.scm
@@ -0,0 +1,591 @@
+;;; TREE-IL -> GLIL compiler
+
+;; Copyright (C) 2001 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 compile-glil)
+ #:use-module (system base syntax)
+ #:use-module (language glil)
+ #:use-module (language tree-il)
+ #:use-module (ice-9 common-list)
+ #: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))))
+
+;; 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))
+(define *ia-return* (make-glil-call 'return 1))
+
+(define (make-label) (gensym ":L"))
+
+(define (make-glil-var op env var)
+ (case (ghil-var-kind var)
+ ((argument)
+ (make-glil-argument op (ghil-var-index var)))
+ ((local)
+ (make-glil-local op (ghil-var-index var)))
+ ((external)
+ (do ((depth 0 (1+ depth))
+ (e env (ghil-env-parent e)))
+ ((eq? e (ghil-var-env var))
+ (make-glil-external op depth (ghil-var-index var)))))
+ ((toplevel)
+ (make-glil-toplevel op (ghil-var-name var)))
+ ((public private)
+ (make-glil-module op (ghil-var-env var) (ghil-var-name var)
+ (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)
+ (set! stack (cons code stack))
+ (if loc (set! stack (cons (make-glil-source loc) stack))))
+ (define (var->binding var)
+ (list (ghil-var-name var) (ghil-var-kind var) (ghil-var-index var)))
+ (define (push-bindings! loc vars)
+ (if (not (null? vars))
+ (push-code! loc (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)
+ (for-each comp-push args)
+ (push-code! loc (make-glil-call inst (length args))))
+ ;; possible tail position
+ (define (comp-tail tree) (comp tree tail drop))
+ ;; push the result
+ (define (comp-push tree) (comp tree #f #f))
+ ;; drop the result
+ (define (comp-drop tree) (comp tree #f #t))
+ ;; drop the result if unnecessary
+ (define (maybe-drop)
+ (if drop (push-code! #f *ia-drop*)))
+ ;; return here if necessary
+ (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))
+ (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)))
+ ;;
+ ;; dispatch
+ (record-case tree
+ ((<ghil-void>)
+ (return-void!))
+
+ ((<ghil-quote> env loc obj)
+ (return-object! loc 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-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)
+ (comp-push val)
+ (push-code! loc (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))
+ (return-void!))
+
+ ((<ghil-if> env loc test then else)
+ ;; TEST
+ ;; (br-if-not L1)
+ ;; THEN
+ ;; (br L2)
+ ;; L1: ELSE
+ ;; L2:
+ (let ((L1 (make-label)) (L2 (make-label)))
+ (comp-push test)
+ (push-branch! loc '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)
+ ;; EXPS...
+ ;; TAIL
+ (if (null? exps)
+ (return-void!)
+ (do ((exps exps (cdr exps)))
+ ((null? (cdr exps))
+ (comp-tail (car exps)))
+ (comp-drop (car exps)))))
+
+ ((<ghil-bind> env loc vars vals body)
+ ;; VALS...
+ ;; (set VARS)...
+ ;; BODY
+ (for-each comp-push vals)
+ (push-bindings! loc 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)
+ ;; VALS...
+ ;; (set VARS)...
+ ;; BODY
+ (let ((MV (make-label)))
+ (comp-push producer)
+ (push-code! loc (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))
+ (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-lambda> env loc vars rest meta body)
+ (return-code! loc (codegen tree)))
+
+ ((<ghil-inline> env loc inline args)
+ ;; ARGS...
+ ;; (INST NARGS)
+ (let ((tail-table '((call . goto/args)
+ (apply . goto/apply)
+ (call/cc . goto/cc))))
+ (cond ((and tail (assq-ref tail-table inline))
+ => (lambda (tail-inst)
+ (push-call! loc tail-inst args)))
+ (else
+ (push-call! loc inline args)
+ (maybe-drop)
+ (maybe-return)))))
+
+ ((<ghil-values> env loc values)
+ (cond (tail ;; (lambda () (values 1 2))
+ (push-call! loc '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))))
+
+ ((<ghil-values*> env loc values)
+ (cond (tail ;; (lambda () (apply values '(1 2)))
+ (push-call! loc '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))))
+
+ ((<ghil-call> env loc 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))
+ (else
+ (push-call! loc 'mark '())
+ (for-each comp-push args)
+ (push-call! loc 'list-mark '())
+ (push-code! loc (make-glil-call (if tail 'goto/apply 'apply) 2)))))
+ (maybe-drop))
+
+ ((<ghil-mv-call> env loc producer consumer)
+ ;; CONSUMER
+ ;; PRODUCER
+ ;; (mv-call MV)
+ ;; ([tail]-call 1)
+ ;; goto POST
+ ;; MV: [tail-]call/nargs
+ ;; POST: (maybe-drop)
+ (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))
+ (cond ((not tail)
+ (push-branch! #f 'br POST)))
+ (push-label! MV)
+ (push-code! loc (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)))))
+
+ ;;
+ ;; main
+ (record-case ghil
+ ((<ghil-lambda> env loc vars rest meta body)
+ (let* ((evars (ghil-env-variables env))
+ (locs (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))
+ (nexts (allocate-indices-linearly! exts)))
+ ;; meta bindings
+ (push-bindings! #f vars)
+ ;; push on definition source location
+ (if loc (set! stack (cons (make-glil-source loc) stack)))
+ ;; copy args to the heap if they're marked as external
+ (do ((n 0 (1+ n))
+ (l vars (cdr l)))
+ ((null? l))
+ (let ((v (car l)))
+ (case (ghil-var-kind v)
+ ((external)
+ (push-code! #f (make-glil-argument 'ref n))
+ (push-code! #f (make-glil-external 'set 0 (ghil-var-index v)))))))
+ ;; compile body
+ (comp body #t #f)
+ ;; create GLIL
+ (make-glil-program nargs (if rest 1 0) nlocs nexts meta
+ (reverse! stack)))))))
+
+(define (allocate-indices-linearly! vars)
+ (do ((n 0 (1+ n))
+ (l vars (cdr l)))
+ ((null? l) n)
+ (let ((v (car l))) (set! (ghil-var-index v) n))))
+
+(define (allocate-locals! vars body)
+ (let ((free '()) (nlocs 0))
+ (define (allocate! var)
+ (cond
+ ((pair? free)
+ (set! (ghil-var-index var) (car free))
+ (set! free (cdr free)))
+ (else
+ (set! (ghil-var-index var) nlocs)
+ (set! nlocs (1+ nlocs)))))
+ (define (deallocate! var)
+ (set! free (cons (ghil-var-index var) free)))
+ (let lp ((x body))
+ (record-case x
+ ((<ghil-void>))
+ ((<ghil-quote>))
+ ((<ghil-quasiquote> exp)
+ (let qlp ((x exp))
+ (cond ((list? x) (for-each qlp x))
+ ((pair? x) (qlp (car x)) (qlp (cdr x)))
+ ((record? x)
+ (record-case x
+ ((<ghil-unquote> exp) (lp exp))
+ ((<ghil-unquote-splicing> exp) (lp exp)))))))
+ ((<ghil-unquote> exp)
+ (lp exp))
+ ((<ghil-unquote-splicing> exp)
+ (lp exp))
+ ((<ghil-reified-env>))
+ ((<ghil-set> val)
+ (lp val))
+ ((<ghil-ref>))
+ ((<ghil-define> val)
+ (lp val))
+ ((<ghil-if> test then else)
+ (lp test) (lp then) (lp else))
+ ((<ghil-and> exps)
+ (for-each lp exps))
+ ((<ghil-or> exps)
+ (for-each lp exps))
+ ((<ghil-begin> exps)
+ (for-each lp exps))
+ ((<ghil-bind> vars vals body)
+ (for-each allocate! vars)
+ (for-each lp vals)
+ (lp body)
+ (for-each deallocate! vars))
+ ((<ghil-mv-bind> vars producer body)
+ (lp producer)
+ (for-each allocate! vars)
+ (lp body)
+ (for-each deallocate! vars))
+ ((<ghil-inline> args)
+ (for-each lp args))
+ ((<ghil-call> proc args)
+ (lp proc)
+ (for-each lp args))
+ ((<ghil-lambda>))
+ ((<ghil-mv-call> producer consumer)
+ (lp producer)
+ (lp consumer))
+ ((<ghil-values> values)
+ (for-each lp values))
+ ((<ghil-values*> values)
+ (for-each lp values))))
+ nlocs))