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