1 ;;; GHIL -> GLIL compiler
3 ;; Copyright (C) 2001 Free Software Foundation, Inc.
5 ;; This program is free software; you can redistribute it and/or modify
6 ;; it under the terms of the GNU General Public License as published by
7 ;; the Free Software Foundation; either version 2, or (at your option)
10 ;; This program is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 ;; GNU General Public License for more details.
15 ;; You should have received a copy of the GNU General Public License
16 ;; along with this program; see the file COPYING. If not, write to
17 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
18 ;; Boston, MA 02111-1307, USA.
22 (define-module (system il compile)
23 :use-module (oop goops)
24 :use-syntax (system base syntax)
25 :use-module (system il glil)
26 :use-module (system il ghil)
27 :use-module (ice-9 common-list)
30 (define (compile x e . opts)
31 (set! x (parse-ghil x e))
32 (if (memq :O opts) (set! x (optimize x)))
37 ;;; Stage 2: Optimization
42 (($ <ghil-call> proc args)
44 ;; ((@lambda (VAR...) BODY...) ARG...) =>
45 ;; (@let ((VAR ARG) ...) BODY...)
46 (($ <ghil-lambda> env vars #f body)
47 (optimize (make-<ghil-bind> vars args body)))
49 (make-<ghil-call> (optimize proc) (for-each optimize args)))))
54 ;;; Stage 3: Code generation
57 (define *ia-void* (make-<glil-void>))
58 (define *ia-drop* (make-<glil-inst> 'drop))
59 (define *ia-return* (make-<glil-inst> 'return))
61 (define (make-label) (gensym ":L"))
63 (define (make-glil-var op env var)
66 (make-<glil-argument> op var.index))
68 (make-<glil-local> op var.index))
70 (do ((depth 0 (1+ depth))
73 (make-<glil-external> op depth var.index))))
75 (make-<glil-module> op var.env var.name))
76 (else (error "Unknown kind of variable:" var))))
78 (define (codegen ghil)
80 (define (push-code! code)
81 (set! stack (cons code stack)))
82 (define (comp tree tail drop)
83 ;; possible tail position
84 (define (comp-tail tree) (comp tree tail drop))
86 (define (comp-push tree) (comp tree #f #f))
88 (define (comp-drop tree) (comp tree #f #t))
89 ;; return this code if necessary
90 (define (return-code! code)
91 (if (not drop) (push-code! code))
92 (if tail (push-code! *ia-return*)))
93 ;; return void if necessary
94 (define (return-void!) (return-code! *ia-void*))
101 (($ <ghil-quote> obj)
102 (return-code! (make-<glil-const> obj)))
104 (($ <ghil-ref> env var)
105 (return-code! (make-glil-var 'ref env var)))
107 (($ <ghil-set> env var val)
109 (push-code! (make-glil-var 'set env var))
112 (($ <ghil-if> test then else)
119 (let ((L1 (make-label)) (L2 (make-label)))
121 (push-code! (make-<glil-branch> 'br-if-not L1))
123 (if (not tail) (push-code! (make-<glil-jump> L2)))
124 (push-code! (make-<glil-label> L1))
126 (if (not tail) (push-code! (make-<glil-label> L2)))))
128 (($ <ghil-begin> exps)
133 (do ((exps exps (cdr exps)))
135 (comp-tail (car exps)))
136 (comp-drop (car exps)))))
138 (($ <ghil-bind> env vars vals body)
142 (for-each comp-push vals)
143 (for-each (lambda (var) (push-code! (make-glil-var 'set env var)))
147 (($ <ghil-lambda> vars rest body)
148 (return-code! (codegen tree)))
150 (($ <ghil-call> proc args)
153 ;; ([tail-]call NARGS)
154 (for-each comp-push args)
156 (let ((inst (if tail 'tail-call 'call)))
157 (push-code! (make-<glil-call> inst (length args))))
158 (if drop (push-code! *ia-drop*)))
160 (($ <ghil-inst> inst args)
163 (for-each comp-push args)
164 (push-code! (make-<glil-inst> inst))
165 (if drop (push-code! *ia-drop*))
166 (if tail (push-code! *ia-return*)))))
170 (($ <ghil-lambda> env args rest body)
171 (let* ((vars env.variables)
172 (locs (pick (lambda (v) (eq? v.kind 'local)) vars))
173 (exts (pick (lambda (v) (eq? v.kind 'external)) vars)))
174 ;; initialize variable indexes
175 (finalize-index! args)
176 (finalize-index! locs)
177 (finalize-index! exts)
179 (do ((n 0 (1+ n)) (l args (cdr l)))
182 (if (eq? v.kind 'external)
183 (begin (push-code! (make-<glil-argument> 'ref n))
184 (push-code! (make-<glil-external> 'set 0 v.index))))))
188 (make-<glil-asm> (length args) (if rest 1 0) (length locs)
189 (length exts) (reverse! stack)))))))
191 (define (finalize-index! list)
195 (let ((v (car l))) (set! v.index n))))