Commit | Line | Data |
---|---|---|
17e90c5e KN |
1 | ;;; GHIL -> GLIL compiler |
2 | ||
3 | ;; Copyright (C) 2001 Free Software Foundation, Inc. | |
4 | ||
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) | |
8 | ;; any later version. | |
9 | ;; | |
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. | |
14 | ;; | |
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. | |
19 | ||
20 | ;;; Code: | |
21 | ||
22 | (define-module (system il compile) | |
23 | :use-module (oop goops) | |
24 | :use-syntax (system base syntax) | |
17e90c5e KN |
25 | :use-module (system il glil) |
26 | :use-module (system il ghil) | |
27 | :use-module (ice-9 common-list) | |
28 | :export (compile)) | |
29 | ||
30 | (define (compile x e . opts) | |
31 | (set! x (parse-ghil x e)) | |
32 | (if (memq :O opts) (set! x (optimize x))) | |
33 | (codegen x)) | |
34 | ||
35 | \f | |
36 | ;;; | |
37 | ;;; Stage 2: Optimization | |
38 | ;;; | |
39 | ||
40 | (define (optimize x) | |
41 | (match x | |
42 | (($ <ghil-call> proc args) | |
43 | (match proc | |
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))) | |
48 | (else | |
49 | (make-<ghil-call> (optimize proc) (for-each optimize args))))) | |
50 | (else x))) | |
51 | ||
52 | \f | |
53 | ;;; | |
54 | ;;; Stage 3: Code generation | |
55 | ;;; | |
56 | ||
57 | (define *ia-void* (make-<glil-void>)) | |
58 | (define *ia-drop* (make-<glil-inst> 'drop)) | |
59 | (define *ia-return* (make-<glil-inst> 'return)) | |
60 | ||
61 | (define (make-label) (gensym ":L")) | |
62 | ||
63 | (define (make-glil-var op env var) | |
64 | (case var.kind | |
65 | ((argument) | |
66 | (make-<glil-argument> op var.index)) | |
67 | ((local) | |
68 | (make-<glil-local> op var.index)) | |
69 | ((external) | |
70 | (do ((depth 0 (1+ depth)) | |
71 | (e env e.parent)) | |
72 | ((eq? e var.env) | |
73 | (make-<glil-external> op depth var.index)))) | |
74 | ((module) | |
75 | (make-<glil-module> op var.env var.name)) | |
76 | (else (error "Unknown kind of variable:" var)))) | |
77 | ||
78 | (define (codegen ghil) | |
79 | (let ((stack '())) | |
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)) | |
85 | ;; push the result | |
86 | (define (comp-push tree) (comp tree #f #f)) | |
87 | ;; drop the result | |
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*)) | |
95 | ;; | |
96 | ;; dispatch | |
97 | (match tree | |
98 | (($ <ghil-void>) | |
99 | (return-void!)) | |
100 | ||
101 | (($ <ghil-quote> obj) | |
102 | (return-code! (make-<glil-const> obj))) | |
103 | ||
104 | (($ <ghil-ref> env var) | |
105 | (return-code! (make-glil-var 'ref env var))) | |
106 | ||
107 | (($ <ghil-set> env var val) | |
108 | (comp-push val) | |
109 | (push-code! (make-glil-var 'set env var)) | |
110 | (return-void!)) | |
111 | ||
112 | (($ <ghil-if> test then else) | |
113 | ;; TEST | |
114 | ;; (br-if-not L1) | |
115 | ;; THEN | |
116 | ;; (jump L2) | |
117 | ;; L1: ELSE | |
118 | ;; L2: | |
119 | (let ((L1 (make-label)) (L2 (make-label))) | |
120 | (comp-push test) | |
121 | (push-code! (make-<glil-branch> 'br-if-not L1)) | |
122 | (comp-tail then) | |
ea9b4b29 | 123 | (if (not tail) (push-code! (make-<glil-branch> 'jump L2))) |
17e90c5e KN |
124 | (push-code! (make-<glil-label> L1)) |
125 | (comp-tail else) | |
126 | (if (not tail) (push-code! (make-<glil-label> L2))))) | |
127 | ||
128 | (($ <ghil-begin> exps) | |
129 | ;; EXPS... | |
130 | ;; TAIL | |
131 | (if (null? exps) | |
132 | (return-void!) | |
133 | (do ((exps exps (cdr exps))) | |
134 | ((null? (cdr exps)) | |
135 | (comp-tail (car exps))) | |
136 | (comp-drop (car exps))))) | |
137 | ||
138 | (($ <ghil-bind> env vars vals body) | |
139 | ;; VALS... | |
140 | ;; (set VARS)... | |
141 | ;; BODY | |
142 | (for-each comp-push vals) | |
143 | (for-each (lambda (var) (push-code! (make-glil-var 'set env var))) | |
144 | (reverse vars)) | |
145 | (comp-tail body)) | |
146 | ||
147 | (($ <ghil-lambda> vars rest body) | |
148 | (return-code! (codegen tree))) | |
149 | ||
150 | (($ <ghil-call> proc args) | |
151 | ;; ARGS... | |
152 | ;; PROC | |
153 | ;; ([tail-]call NARGS) | |
154 | (for-each comp-push args) | |
155 | (comp-push proc) | |
156 | (let ((inst (if tail 'tail-call 'call))) | |
157 | (push-code! (make-<glil-call> inst (length args)))) | |
158 | (if drop (push-code! *ia-drop*))) | |
159 | ||
160 | (($ <ghil-inst> inst args) | |
161 | ;; ARGS... | |
162 | ;; (INST) | |
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*))))) | |
167 | ;; | |
168 | ;; main | |
169 | (match ghil | |
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) | |
178 | ;; export arguments | |
179 | (do ((n 0 (1+ n)) (l args (cdr l))) | |
180 | ((null? l)) | |
181 | (let ((v (car 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)))))) | |
185 | ;; compile body | |
186 | (comp body #t #f) | |
187 | ;; create GLIL | |
188 | (make-<glil-asm> (length args) (if rest 1 0) (length locs) | |
189 | (length exts) (reverse! stack))))))) | |
190 | ||
191 | (define (finalize-index! list) | |
192 | (do ((n 0 (1+ n)) | |
193 | (l list (cdr l))) | |
194 | ((null? l)) | |
195 | (let ((v (car l))) (set! v.index n)))) |