1 ;;; Guile Low Intermediate Language
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 glil)
23 #:use-module (system base syntax)
24 #:use-module (system base pmatch)
25 #:use-module ((srfi srfi-1) #:select (fold))
27 (<glil-program> make-glil-program glil-program?
28 glil-program-nargs glil-program-nrest glil-program-nlocs glil-program-nexts
29 glil-program-meta glil-program-body glil-program-closure-level
31 <glil-bind> make-glil-bind glil-bind?
34 <glil-mv-bind> make-glil-mv-bind glil-mv-bind?
35 glil-mv-bind-vars glil-mv-bind-rest
37 <glil-unbind> make-glil-unbind glil-unbind?
39 <glil-source> make-glil-source glil-source?
42 <glil-void> make-glil-void glil-void?
44 <glil-const> make-glil-const glil-const?
47 <glil-argument> make-glil-argument glil-argument?
48 glil-argument-op glil-argument-index
50 <glil-local> make-glil-local glil-local?
51 glil-local-op glil-local-index
53 <glil-external> make-glil-external glil-external?
54 glil-external-op glil-external-depth glil-external-index
56 <glil-toplevel> make-glil-toplevel glil-toplevel?
57 glil-toplevel-op glil-toplevel-name
59 <glil-module> make-glil-module glil-module?
60 glil-module-op glil-module-mod glil-module-name glil-module-public?
62 <glil-label> make-glil-label glil-label?
65 <glil-branch> make-glil-branch glil-branch?
66 glil-branch-inst glil-branch-label
68 <glil-call> make-glil-call glil-call?
69 glil-call-inst glil-call-nargs
71 <glil-mv-call> make-glil-mv-call glil-mv-call?
72 glil-mv-call-nargs glil-mv-call-ra
74 parse-glil unparse-glil))
76 (define (print-glil x port)
77 (format port "#<glil ~s>" (unparse-glil x)))
79 (define-type (<glil> #:printer print-glil)
81 (<glil-program> nargs nrest nlocs nexts meta body (closure-level #f))
83 (<glil-mv-bind> vars rest)
90 (<glil-argument> op index)
91 (<glil-local> op index)
92 (<glil-external> op depth index)
93 (<glil-toplevel> op name)
94 (<glil-module> op mod name public?)
97 (<glil-branch> inst label)
98 (<glil-call> inst nargs)
99 (<glil-mv-call> nargs ra))
101 (define (compute-closure-level body)
102 (fold (lambda (x ret)
104 ((<glil-program> closure-level) (max ret closure-level))
105 ((<glil-external> depth) (max ret depth))
109 (define %make-glil-program make-glil-program)
110 (define (make-glil-program . args)
111 (let ((prog (apply %make-glil-program args)))
112 (if (not (glil-program-closure-level prog))
113 (set! (glil-program-closure-level prog)
114 (compute-closure-level (glil-program-body prog))))
118 (define (parse-glil x)
120 ((program ,nargs ,nrest ,nlocs ,nexts ,meta . ,body)
121 (make-glil-program nargs nrest nlocs nexts meta (map parse-glil body)))
122 ((bind . ,vars) (make-glil-bind vars))
123 ((mv-bind ,vars . ,rest) (make-glil-mv-bind vars (map parse-glil rest)))
124 ((unbind) (make-glil-unbind))
125 ((source ,loc) (make-glil-source loc))
126 ((void) (make-glil-void))
127 ((const ,obj) (make-glil-const obj))
128 ((argument ,op ,index) (make-glil-argument op index))
129 ((local ,op ,index) (make-glil-local op index))
130 ((external ,op ,depth ,index) (make-glil-external op depth index))
131 ((toplevel ,op ,name) (make-glil-toplevel op name))
132 ((module public ,op ,mod ,name) (make-glil-module op mod name #t))
133 ((module private ,op ,mod ,name) (make-glil-module op mod name #f))
134 ((label ,label) (make-label ,label))
135 ((branch ,inst ,label) (make-glil-branch inst label))
136 ((call ,inst ,nargs) (make-glil-call inst nargs))
137 ((mv-call ,nargs ,ra) (make-glil-mv-call nargs ra))
138 (else (error "invalid glil" x))))
140 (define (unparse-glil glil)
143 ((<glil-program> nargs nrest nlocs nexts meta body)
144 `(program ,nargs ,nrest ,nlocs ,nexts ,meta ,@(map unparse-glil body)))
145 ((<glil-bind> vars) `(bind ,@vars))
146 ((<glil-mv-bind> vars rest) `(mv-bind ,vars ,@rest))
147 ((<glil-unbind>) `(unbind))
148 ((<glil-source> loc) `(source ,loc))
150 ((<glil-void>) `(void))
151 ((<glil-const> obj) `(const ,obj))
153 ((<glil-argument> op index)
154 `(argument ,op ,index))
155 ((<glil-local> op index)
157 ((<glil-external> op depth index)
158 `(external ,op ,depth ,index))
159 ((<glil-toplevel> op name)
160 `(toplevel ,op ,name))
161 ((<glil-module> op mod name public?)
162 `(module ,(if public? 'public 'private) ,op ,mod ,name))
164 ((<glil-label> label) `(label ,label))
165 ((<glil-branch> inst label) `(branch ,inst ,label))
166 ((<glil-call> inst nargs) `(call ,inst ,nargs))
167 ((<glil-mv-call> nargs ra) `(mv-call ,nargs ,(unparse-glil ra)))))