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 (language ghil compile-glil)
23 #:use-syntax (system base syntax)
24 #:use-module (language glil def)
25 #:use-module (language ghil def)
26 #:use-module (ice-9 common-list)
27 #:export (compile-glil))
29 (define (compile-glil x e opts)
30 (if (memq #:O opts) (set! x (optimize x)))
32 (and e (cons (car e) (cddr e)))))
36 ;;; Stage 2: Optimization
39 (define (lift-variables! env)
40 (let ((parent-env (ghil-env-parent env)))
42 (case (ghil-var-kind v)
43 ((argument) (set! (ghil-var-kind v) 'local)))
44 (set! (ghil-var-env v) parent-env)
45 (ghil-env-add! parent-env v))
46 (ghil-env-variables env))))
50 ((<ghil-set> env loc var val)
51 (make-ghil-set env var (optimize val)))
53 ((<ghil-define> env loc var val)
54 (make-ghil-define env var (optimize val)))
56 ((<ghil-if> env loc test then else)
57 (make-ghil-if env loc (optimize test) (optimize then) (optimize else)))
59 ((<ghil-and> env loc exps)
60 (make-ghil-and env loc (map optimize exps)))
62 ((<ghil-or> env loc exps)
63 (make-ghil-or env loc (map optimize exps)))
65 ((<ghil-begin> env loc exps)
66 (make-ghil-begin env loc (map optimize exps)))
68 ((<ghil-bind> env loc vars vals body)
69 (make-ghil-bind env loc vars (map optimize vals) (optimize body)))
71 ((<ghil-lambda> env loc vars rest meta body)
72 (make-ghil-lambda env loc vars rest meta (optimize body)))
74 ((<ghil-inline> env loc instruction args)
75 (make-ghil-inline env loc instruction (map optimize args)))
77 ((<ghil-call> env loc proc args)
78 (let ((parent-env env))
80 ;; ((@lambda (VAR...) BODY...) ARG...) =>
81 ;; (@let ((VAR ARG) ...) BODY...)
82 ((<ghil-lambda> env loc vars rest meta body)
86 (make-ghil-bind parent-env loc (map optimize args)))
88 (make-ghil-call parent-env loc (optimize proc) (map optimize args)))))
90 (make-ghil-call parent-env loc (optimize proc) (map optimize args))))))
92 ((<ghil-mv-call> env loc producer consumer)
94 ;; (mv-call PRODUCER (lambda ARGS BODY...)) =>
95 ;; (mv-let PRODUCER ARGS BODY...)
96 ((<ghil-lambda> env loc vars rest meta body)
98 (make-ghil-mv-bind producer vars rest body))
100 (make-ghil-mv-call env loc (optimize producer) (optimize consumer)))))
106 ;;; Stage 3: Code generation
109 (define *ia-void* (make-glil-void))
110 (define *ia-drop* (make-glil-call 'drop 0))
111 (define *ia-return* (make-glil-call 'return 0))
113 (define (make-label) (gensym ":L"))
115 (define (make-glil-var op env var)
116 (case (ghil-var-kind var)
118 (make-glil-argument op (ghil-var-index var)))
120 (make-glil-local op (ghil-var-index var)))
122 (do ((depth 0 (1+ depth))
123 (e env (ghil-env-parent e)))
124 ((eq? e (ghil-var-env var))
125 (make-glil-external op depth (ghil-var-index var)))))
127 (make-glil-toplevel op (ghil-var-name var)))
129 (make-glil-module op (ghil-var-env var) (ghil-var-name var)
130 (eq? (ghil-var-kind var) 'public)))
131 (else (error "Unknown kind of variable:" var))))
133 (define (constant? x)
134 (cond ((or (number? x) (string? x) (symbol? x) (keyword? x) (boolean? x)) #t)
135 ((pair? x) (and (constant? (car x))
136 (constant? (cdr x))))
137 ((vector? x) (let lp ((i (vector-length x)))
139 (and (constant? (vector-ref x (1- i)))
142 (define (codegen ghil)
144 (define (push-code! loc code)
145 (set! stack (cons code stack))
146 (if loc (set! stack (cons (make-glil-source loc) stack))))
147 (define (var->binding var)
148 (list (ghil-var-name var) (ghil-var-kind var) (ghil-var-index var)))
149 (define (push-bindings! loc vars)
150 (if (not (null? vars))
151 (push-code! loc (make-glil-bind (map var->binding vars)))))
152 (define (comp tree tail drop)
153 (define (push-label! label)
154 (push-code! #f (make-glil-label label)))
155 (define (push-branch! loc inst label)
156 (push-code! loc (make-glil-branch inst label)))
157 (define (push-call! loc inst args)
158 (for-each comp-push args)
159 (push-code! loc (make-glil-call inst (length args))))
160 ;; possible tail position
161 (define (comp-tail tree) (comp tree tail drop))
163 (define (comp-push tree) (comp tree #f #f))
165 (define (comp-drop tree) (comp tree #f #t))
166 ;; drop the result if unnecessary
168 (if drop (push-code! #f *ia-drop*)))
169 ;; return here if necessary
170 (define (maybe-return)
171 (if tail (push-code! #f *ia-return*)))
172 ;; return this code if necessary
173 (define (return-code! loc code)
174 (if (not drop) (push-code! loc code))
176 ;; return void if necessary
177 (define (return-void!)
178 (return-code! #f *ia-void*))
179 ;; return object if necessary
180 (define (return-object! loc obj)
181 (return-code! loc (make-glil-const #:obj obj)))
188 ((<ghil-quote> env loc obj)
189 (return-object! loc obj))
191 ((<ghil-quasiquote> env loc exp)
192 (let loop ((x exp) (in-car? #f))
195 (push-call! #f 'mark '())
196 (for-each (lambda (x) (loop x #t)) x)
197 (push-call! #f 'list-mark '()))
199 (push-call! #f 'mark '())
202 (push-call! #f 'cons-mark '()))
205 ((<ghil-unquote> env loc exp)
207 ((<ghil-unquote-splicing> env loc exp)
209 (error "unquote-splicing in the cdr of a pair" exp))
211 (push-call! #f 'list-break '()))))
213 (push-code! #f (make-glil-const #:obj x)))
215 (error "element of quasiquote can't be compiled" x))))
219 ((<ghil-ref> env loc var)
220 (return-code! loc (make-glil-var 'ref env var)))
222 ((<ghil-set> env loc var val)
224 (push-code! loc (make-glil-var 'set env var))
227 ((<ghil-define> env loc var val)
229 (push-code! loc (make-glil-var 'define env var))
232 ((<ghil-if> env loc test then else)
239 (let ((L1 (make-label)) (L2 (make-label)))
241 (push-branch! loc 'br-if-not L1)
243 (if (not tail) (push-branch! #f 'br L2))
246 (if (not tail) (push-label! L2))))
248 ((<ghil-and> env loc exps)
256 (cond ((null? exps) (return-object! loc #t))
257 ((null? (cdr exps)) (comp-tail (car exps)))
259 (let ((L1 (make-label)) (L2 (make-label)))
260 (let lp ((exps exps))
261 (cond ((null? (cdr exps))
262 (comp-tail (car exps))
263 (push-branch! #f 'br L2)
265 (return-object! #f #f)
269 (comp-push (car exps))
270 (push-branch! #f 'br-if-not L1)
271 (lp (cdr exps)))))))))
273 ((<ghil-or> env loc exps)
281 (cond ((null? exps) (return-object! loc #f))
282 ((null? (cdr exps)) (comp-tail (car exps)))
284 (let ((L1 (make-label)))
285 (let lp ((exps exps))
286 (cond ((null? (cdr exps))
287 (comp-tail (car exps))
291 (comp-push (car exps))
293 (push-call! #f 'dup '()))
294 (push-branch! #f 'br-if L1)
296 (push-call! #f 'drop '()))
297 (lp (cdr exps)))))))))
299 ((<ghil-begin> env loc exps)
304 (do ((exps exps (cdr exps)))
306 (comp-tail (car exps)))
307 (comp-drop (car exps)))))
309 ((<ghil-bind> env loc vars vals body)
313 (for-each comp-push vals)
314 (push-bindings! loc vars)
315 (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var)))
318 (push-code! #f (make-glil-unbind)))
320 ((<ghil-mv-bind> env loc producer vars rest body)
324 (let ((MV (make-label)))
326 (push-code! loc (make-glil-mv-call 0 MV))
327 (push-code! #f (make-glil-const #:obj 1))
329 (push-code! #f (make-glil-mv-bind (map var->binding vars) rest))
330 (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var)))
333 (push-code! #f (make-glil-unbind)))
335 ((<ghil-lambda> env loc vars rest meta body)
336 (return-code! loc (codegen tree)))
338 ((<ghil-inline> env loc inline args)
341 (let ((tail-table '((call . goto/args)
343 (call/cc . goto/cc))))
344 (cond ((and tail (assq-ref tail-table inline))
345 => (lambda (tail-inst)
346 (push-call! loc tail-inst args)))
348 (push-call! loc inline args)
352 ((<ghil-values> env loc values)
353 (cond (tail ;; (lambda () (values 1 2))
354 (push-call! loc 'return/values values))
355 (drop ;; (lambda () (values 1 2) 3)
356 (for-each comp-drop values))
357 (else ;; (lambda () (list (values 10 12) 1))
358 (push-code! #f (make-glil-const #:obj 'values))
359 (push-code! #f (make-glil-call #:inst 'link-now #:nargs 1))
360 (push-code! #f (make-glil-call #:inst 'variable-ref #:nargs 0))
361 (push-call! loc 'call values))))
363 ((<ghil-values*> env loc values)
364 (cond (tail ;; (lambda () (apply values '(1 2)))
365 (push-call! loc 'return/values* values))
366 (drop ;; (lambda () (apply values '(1 2)) 3)
367 (for-each comp-drop values))
368 (else ;; (lambda () (list (apply values '(10 12)) 1))
369 (push-code! #f (make-glil-const #:obj 'values))
370 (push-code! #f (make-glil-call #:inst 'link-now #:nargs 1))
371 (push-code! #f (make-glil-call #:inst 'variable-ref #:nargs 0))
372 (push-call! loc 'apply values))))
374 ((<ghil-call> env loc proc args)
377 ;; ([tail-]call NARGS)
379 (push-call! loc (if tail 'goto/args 'call) args)
382 ((<ghil-mv-call> env loc producer consumer)
388 ;; MV: [tail-]call/nargs
389 ;; POST: (maybe-drop)
390 (let ((MV (make-label)) (POST (make-label)))
393 (push-code! loc (make-glil-mv-call 0 MV))
394 (push-code! loc (make-glil-call (if tail 'goto/args 'call) 1))
396 (push-branch! #f 'br POST)))
398 (push-code! loc (make-glil-call (if tail 'goto/nargs 'call/nargs) 0))
403 ((<ghil-reified-env> env loc)
404 (return-object! loc (ghil-env-reify env)))))
409 ((<ghil-lambda> env loc vars rest meta body)
410 (let* ((evars (ghil-env-variables env))
411 (locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars))
412 (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars)))
413 ;; initialize variable indexes
414 (finalize-index! vars)
415 (finalize-index! locs)
416 (finalize-index! exts)
418 (push-bindings! #f vars)
424 (case (ghil-var-kind v)
426 (push-code! #f (make-glil-argument 'ref n))
427 (push-code! #f (make-glil-external 'set 0 (ghil-var-index v)))))))
431 (let ((vars (make-glil-vars #:nargs (length vars)
432 #:nrest (if rest 1 0)
433 #:nlocs (length locs)
434 #:nexts (length exts))))
435 (make-glil-asm vars meta (reverse! stack))))))))
437 (define (finalize-index! list)
441 (let ((v (car l))) (set! (ghil-var-index v) n))))