Commit | Line | Data |
---|---|---|
17e90c5e KN |
1 | ;;; Guile Low Intermediate Language |
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 glil) | |
ac99cb0c | 23 | :use-syntax (system base syntax) |
17e90c5e KN |
24 | :export |
25 | (pprint-glil | |
849cefac | 26 | <glil-vars> make-glil-vars |
bdaffda2 | 27 | glil-vars-nargs glil-vars-nrest glil-vars-nlocs glil-vars-nexts |
01967b69 AW |
28 | |
29 | <glil-asm> make-glil-asm glil-asm? | |
bdaffda2 | 30 | glil-asm-vars glil-asm-body |
01967b69 AW |
31 | |
32 | <glil-bind> make-glil-bind glil-bind? | |
bdaffda2 | 33 | glil-bind-vars |
01967b69 AW |
34 | |
35 | <glil-unbind> make-glil-unbind glil-unbind? | |
36 | ||
37 | <glil-source> make-glil-source glil-source? | |
bdaffda2 | 38 | glil-source-loc |
17e90c5e | 39 | |
01967b69 AW |
40 | <glil-void> make-glil-void glil-void? |
41 | ||
42 | <glil-const> make-glil-const glil-const? | |
bdaffda2 | 43 | glil-const-obj |
17e90c5e | 44 | |
01967b69 | 45 | <glil-argument> make-glil-argument glil-argument? |
bdaffda2 | 46 | glil-argument-op glil-argument-index |
01967b69 AW |
47 | |
48 | <glil-local> make-glil-local glil-local? | |
bdaffda2 | 49 | glil-local-op glil-local-index |
01967b69 AW |
50 | |
51 | <glil-external> make-glil-external glil-external? | |
bdaffda2 | 52 | glil-external-op glil-external-depth glil-external-index |
01967b69 AW |
53 | |
54 | <glil-module> make-glil-module glil-module? | |
bdaffda2 | 55 | glil-module-op glil-module-module glil-module-index |
17e90c5e | 56 | |
01967b69 | 57 | <glil-label> make-glil-label glil-label? |
bdaffda2 | 58 | glil-label-label |
01967b69 AW |
59 | |
60 | <glil-branch> make-glil-branch glil-branch? | |
bdaffda2 | 61 | glil-branch-int glil-branch-label |
01967b69 AW |
62 | |
63 | <glil-call> make-glil-call glil-call? | |
64 | glil-call-int glil-call-nargs)) | |
17e90c5e | 65 | |
ac99cb0c KN |
66 | (define-record (<glil-vars> nargs nrest nlocs nexts)) |
67 | ||
68 | (define-type <glil> | |
69 | (| | |
70 | ;; Meta operations | |
71 | (<glil-asm> vars body) | |
72 | (<glil-bind> vars) | |
73 | (<glil-unbind>) | |
74 | (<glil-source> loc) | |
75 | ;; Objects | |
76 | (<glil-void>) | |
77 | (<glil-const> obj) | |
78 | ;; Variables | |
79 | (<glil-argument> op index) | |
80 | (<glil-local> op index) | |
81 | (<glil-external> op depth index) | |
82 | (<glil-module> op module name) | |
83 | ;; Controls | |
84 | (<glil-label> label) | |
85 | (<glil-branch> inst label) | |
86 | (<glil-call> inst nargs))) | |
17e90c5e KN |
87 | |
88 | \f | |
89 | ;;; | |
90 | ;;; Parser | |
91 | ;;; | |
92 | ||
17e90c5e KN |
93 | ;;; (define (parse-glil x) |
94 | ;;; (match x | |
95 | ;;; (('@asm args . body) | |
96 | ;;; (let* ((env (make-new-env e)) | |
97 | ;;; (args (parse-args args env))) | |
98 | ;;; (make-asm env args (map-parse body env)))) | |
99 | ;;; (else | |
100 | ;;; (error "Invalid assembly code:" x)))) | |
101 | ;;; | |
102 | ;;; (define (parse-args x e) | |
103 | ;;; (let ((args (cond ((symbol? x) (make-args (list (make-local-var x)) #t)) | |
104 | ;;; ((list? x) (make-args (map make-local-var x) #f)) | |
105 | ;;; (else (let loop ((l x) (v '())) | |
106 | ;;; (if (pair? l) | |
107 | ;;; (loop (cdr l) (cons (car l) v)) | |
108 | ;;; (make-args (map make-local-var | |
109 | ;;; (reverse! (cons l v))) | |
110 | ;;; #t))))))) | |
111 | ;;; (for-each (lambda (v) (env-add! e v)) (args-vars args)) | |
112 | ;;; args)) | |
113 | ;;; | |
114 | ;;; (define (map-parse x e) | |
115 | ;;; (map (lambda (x) (parse x e)) x)) | |
116 | ;;; | |
117 | ;;; (define (parse x e) | |
118 | ;;; (match x | |
119 | ;;; ;; (@asm ARGS BODY...) | |
120 | ;;; (('@asm args . body) | |
121 | ;;; (parse-asm x e)) | |
122 | ;;; ;; (@bind VARS BODY...) | |
123 | ;;; ;; (@block VARS BODY...) | |
124 | ;;; (((or '@bind '@block) vars . body) | |
125 | ;;; (let* ((offset (env-nvars e)) | |
126 | ;;; (vars (args-vars (parse-args vars e))) | |
127 | ;;; (block (make-block (car x) offset vars (map-parse body e)))) | |
128 | ;;; (for-each (lambda (v) (env-remove! e)) vars) | |
129 | ;;; block)) | |
130 | ;;; ;; (void) | |
131 | ;;; (('void) | |
132 | ;;; (make-void)) | |
133 | ;;; ;; (const OBJ) | |
134 | ;;; (('const obj) | |
135 | ;;; (make-const obj)) | |
136 | ;;; ;; (ref NAME) | |
137 | ;;; ;; (set NAME) | |
138 | ;;; (((or 'ref 'set) name) | |
139 | ;;; (make-access (car x) (env-ref e name))) | |
140 | ;;; ;; (label LABEL) | |
141 | ;;; (('label label) | |
142 | ;;; (make-label label)) | |
143 | ;;; ;; (br-if LABEL) | |
144 | ;;; ;; (jump LABEL) | |
145 | ;;; (((or 'br-if 'jump) label) | |
146 | ;;; (make-instl (car x) label)) | |
147 | ;;; ;; (call NARGS) | |
148 | ;;; ;; (tail-call NARGS) | |
149 | ;;; (((or 'call 'tail-call) n) | |
150 | ;;; (make-instn (car x) n)) | |
151 | ;;; ;; (INST) | |
152 | ;;; ((inst) | |
153 | ;;; (if (instruction? inst) | |
154 | ;;; (make-inst inst) | |
155 | ;;; (error "Unknown instruction:" inst))))) | |
156 | ||
157 | \f | |
158 | ;;; | |
159 | ;;; Unparser | |
160 | ;;; | |
161 | ||
162 | (define (unparse glil) | |
67169b29 | 163 | (record-case glil |
17e90c5e | 164 | ;; meta |
67169b29 | 165 | ((<glil-asm> vars body) |
61dc81d9 AW |
166 | `(@asm (,(glil-vars-nargs vars) ,(glil-vars-nrest vars) |
167 | ,(glil-vars-nlocs vars) ,(glil-vars-nexts vars)) | |
ac99cb0c | 168 | ,@(map unparse body))) |
67169b29 AW |
169 | ((<glil-bind> vars) `(@bind ,@vars)) |
170 | ((<glil-unbind>) `(@unbind)) | |
171 | ((<glil-source> loc) `(@source ,(car loc) ,(cdr loc))) | |
17e90c5e | 172 | ;; constants |
67169b29 AW |
173 | ((<glil-void>) `(void)) |
174 | ((<glil-const> obj) `(const ,obj)) | |
17e90c5e | 175 | ;; variables |
67169b29 | 176 | ((<glil-argument> op index) |
17e90c5e | 177 | `(,(symbol-append 'argument- op) ,index)) |
67169b29 | 178 | ((<glil-local> op index) |
17e90c5e | 179 | `(,(symbol-append 'local- op) ,index)) |
67169b29 | 180 | ((<glil-external> op depth index) |
17e90c5e | 181 | `(,(symbol-append 'external- op) ,depth ,index)) |
67169b29 | 182 | ((<glil-module> op module name) |
17e90c5e KN |
183 | `(,(symbol-append 'module- op) ,module ,name)) |
184 | ;; controls | |
67169b29 AW |
185 | ((<glil-label> label) label) |
186 | ((<glil-branch> inst label) `(,inst ,label)) | |
187 | ((<glil-call> inst nargs) `(,inst ,nargs)))) | |
17e90c5e KN |
188 | |
189 | \f | |
190 | ;;; | |
191 | ;;; Printer | |
192 | ;;; | |
193 | ||
ac99cb0c KN |
194 | (define (pprint-glil glil . port) |
195 | (let ((port (if (pair? port) (car port) (current-output-port)))) | |
196 | (let print ((code (unparse glil)) (column 0)) | |
197 | (display (make-string column #\space) port) | |
198 | (cond ((and (pair? code) (eq? (car code) '@asm)) | |
199 | (format port "(@asm ~A\n" (cadr code)) | |
200 | (let ((col (+ column 2))) | |
201 | (let loop ((l (cddr code))) | |
202 | (print (car l) col) | |
203 | (if (null? (cdr l)) | |
204 | (display ")" port) | |
205 | (begin (newline port) (loop (cdr l))))))) | |
206 | (else (write code port)))) | |
207 | (newline port))) |