3 ;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
5 ;;;; This library is free software; you can redistribute it and/or
6 ;;;; modify it under the terms of the GNU Lesser General Public
7 ;;;; License as published by the Free Software Foundation; either
8 ;;;; version 3 of the License, or (at your option) any later version.
10 ;;;; This library 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 GNU
13 ;;;; Lesser General Public License for more details.
15 ;;;; You should have received a copy of the GNU Lesser General Public
16 ;;;; License along with this library; if not, write to the Free Software
17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
21 (define-module (language glil compile-assembly)
22 #:use-module (system base syntax)
23 #:use-module (system base pmatch)
24 #:use-module (language glil)
25 #:use-module (language assembly)
26 #:use-module (system vm instruction)
27 #:use-module ((system vm program) #:select (make-binding))
28 #:use-module (ice-9 receive)
29 #:use-module ((srfi srfi-1) #:select (fold))
30 #:use-module (rnrs bytevector)
31 #:export (compile-assembly))
33 ;; Variable cache cells go in the object table, and serialize as their
34 ;; keys. The reason we wrap the keys in these records is so they don't
35 ;; compare as `equal?' to other objects in the object table.
37 ;; `key' is either a symbol or the list (MODNAME SYM PUBLIC?)
39 (define-record <variable-cache-cell> key)
41 ;; Subprograms can be loaded into an object table as well. We need a
42 ;; disjoint type here too. (Subprograms have their own object tables --
43 ;; though probably we should just make one table per compilation unit.)
45 (define-record <subprogram> table prog)
48 (define (limn-sources sources)
49 (let lp ((in sources) (out '()) (filename #f))
52 (let ((addr (caar in))
53 (new-filename (assq-ref (cdar in ) 'filename))
54 (line (assq-ref (cdar in) 'line))
55 (column (assq-ref (cdar in) 'column)))
57 ((not (equal? new-filename filename))
59 `((,addr . (,line . ,column))
60 (filename . ,new-filename)
63 ((or (null? out) (not (equal? (cdar out) `(,line . ,column))))
65 `((,addr . (,line . ,column))
69 (lp (cdr in) out filename)))))))
71 (define (make-meta bindings sources tail)
72 (if (and (null? bindings) (null? sources) (null? tail))
75 (make-glil-program 0 0 0 '()
77 (make-glil-const `(,bindings ,sources ,@tail))
78 (make-glil-call 'return 1))))))
80 ;; A functional stack of names of live variables.
81 (define (make-open-binding name boxed? index)
82 (list name boxed? index))
83 (define (make-closed-binding open-binding start end)
84 (make-binding (car open-binding) (cadr open-binding)
85 (caddr open-binding) start end))
86 (define (open-binding bindings vars start)
93 (make-open-binding name boxed? i))
94 (else (error "unknown binding type" v))))
98 (define (close-binding bindings end)
100 ((((,start . ,closing) . ,open) . ,closed)
102 (fold (lambda (o tail)
103 ;; the cons is for dsu sort
104 (acons start (make-closed-binding o start end)
108 (else (error "broken bindings" bindings))))
109 (define (close-all-bindings bindings end)
110 (if (null? (car bindings))
112 (stable-sort (reverse (cdr bindings))
113 (lambda (x y) (< (car x) (car y)))))
114 (close-all-bindings (close-binding bindings end) end)))
116 ;; A functional object table.
118 (define (assoc-ref-or-acons alist x make-y)
119 (cond ((assoc-ref alist x)
120 => (lambda (y) (values y alist)))
122 (let ((y (make-y x alist)))
123 (values y (acons x y alist))))))
124 (define (object-index-and-alist x alist)
125 (assoc-ref-or-acons alist x
127 (+ (length alist) *module*))))
129 (define (compile-assembly glil)
131 (glil->assembly glil #t '(()) '() '() #f -1)
133 (define (make-object-table objects)
134 (and (not (null? objects))
135 (list->vector (cons #f objects))))
137 (define (glil->assembly glil toplevel? bindings
138 source-alist label-alist object-alist addr)
139 (define (emit-code x)
140 (values (map assembly-pack x) bindings source-alist label-alist object-alist))
141 (define (emit-code/object x object-alist)
142 (values (map assembly-pack x) bindings source-alist label-alist object-alist))
145 ((<glil-program> nargs nrest nlocs meta body)
146 (define (process-body)
147 (let lp ((body body) (code '()) (bindings '(())) (source-alist '())
148 (label-alist '()) (object-alist (if toplevel? #f '())) (addr 0))
151 (values (reverse code)
152 (close-all-bindings bindings addr)
153 (limn-sources (reverse! source-alist))
154 (reverse label-alist)
155 (and object-alist (map car (reverse object-alist)))
158 (receive (subcode bindings source-alist label-alist object-alist)
159 (glil->assembly (car body) #f bindings
160 source-alist label-alist object-alist addr)
161 (lp (cdr body) (append (reverse subcode) code)
162 bindings source-alist label-alist object-alist
163 (addr+ addr subcode)))))))
165 (receive (code bindings sources labels objects len)
167 (let ((prog `(load-program ,nargs ,nrest ,nlocs ,labels
169 ,(make-meta bindings sources meta)
173 ;; toplevel bytecode isn't loaded by the vm, no way to do
174 ;; object table or closure capture (not in the bytecode,
176 (emit-code (align-program prog addr)))
178 (let ((table (dump-object (make-object-table objects) addr)))
181 ;; if we are being compiled from something with an object
182 ;; table, cache the program there
183 (receive (i object-alist)
184 (object-index-and-alist (make-subprogram table prog)
186 (emit-code/object `(,(if (< i 256)
188 `(long-object-ref ,(quotient i 256)
192 ;; otherwise emit a load directly
193 (emit-code `(,@table ,@(align-program prog (addr+ addr table))))))))))))
198 (open-binding bindings vars addr)
203 ((<glil-mv-bind> vars rest)
204 (values `((truncate-values ,(length vars) ,(if rest 1 0)))
205 (open-binding bindings vars addr)
212 (close-binding bindings addr)
217 ((<glil-source> props)
220 (acons addr props source-alist)
225 (emit-code '((void))))
229 ((object->assembly obj)
231 (emit-code (list code))))
233 (emit-code (dump-object obj addr)))
235 (receive (i object-alist)
236 (object-index-and-alist obj object-alist)
237 (emit-code/object (if (< i 256)
239 `((long-object-ref ,(quotient i 256)
243 ((<glil-lexical> local? boxed? op index)
248 ((ref) (if boxed? 'local-boxed-ref 'local-ref))
249 ((set) (if boxed? 'local-boxed-set 'local-set))
251 ((empty-box) 'empty-box)
252 (else (error "what" op)))
254 (let ((a (quotient i 256))
259 `((long-local-ref ,a ,b)
261 `((long-local-ref ,a ,b))))
264 `((long-local-ref ,a ,b)
266 `((long-local-set ,a ,b))))
270 (long-local-set ,a ,b)))
273 (long-local-set ,a ,b)))
274 (else (error "what" op)))
277 ((ref) (if boxed? 'free-boxed-ref 'free-ref))
278 ((set) (if boxed? 'free-boxed-set (error "what." glil)))
279 (else (error "what" op)))
282 ((<glil-toplevel> op name)
287 (emit-code `(,@(dump-object name addr)
290 ((ref) '(variable-ref))
291 ((set) '(variable-set))))))
293 (receive (i object-alist)
294 (object-index-and-alist (make-variable-cache-cell name)
296 (emit-code/object (if (< i 256)
298 ((ref) 'toplevel-ref)
299 ((set) 'toplevel-set))
302 ((ref) 'long-toplevel-ref)
303 ((set) 'long-toplevel-set))
308 (emit-code `((define ,(symbol->string name))
311 (error "unknown toplevel var kind" op name))))
313 ((<glil-module> op mod name public?)
314 (let ((key (list mod name public?)))
319 (emit-code `(,@(dump-object key addr)
322 ((ref) '(variable-ref))
323 ((set) '(variable-set))))))
325 (receive (i object-alist)
326 (object-index-and-alist (make-variable-cache-cell key)
328 (emit-code/object (case op
329 ((ref) `((toplevel-ref ,i)))
330 ((set) `((toplevel-set ,i))))
333 (error "unknown module var kind" op key)))))
335 ((<glil-label> label)
339 (acons label addr label-alist)
342 ((<glil-branch> inst label)
343 (emit-code `((,inst ,label))))
345 ;; nargs is number of stack args to insn. probably should rename.
346 ((<glil-call> inst nargs)
347 (if (not (instruction? inst))
348 (error "Unknown instruction:" inst))
349 (let ((pops (instruction-pops inst)))
351 (case (instruction-length inst)
352 ((1) (emit-code `((,inst ,nargs))))
353 ((2) (emit-code `((,inst ,(quotient nargs 256)
354 ,(modulo nargs 256)))))
355 (else (error "Unknown length for variable-arg instruction:"
356 inst (instruction-length inst)))))
358 (emit-code `((,inst))))
360 (error "Wrong number of stack arguments to instruction:" inst nargs)))))
362 ((<glil-mv-call> nargs ra)
363 (emit-code `((mv-call ,nargs ,ra))))))
365 (define (dump-object x addr)
367 (error (string-append x " too long")))
370 ((object->assembly x) => list)
371 ((variable-cache-cell? x) (dump-object (variable-cache-cell-key x) addr))
373 `(,@(subprogram-table x)
374 ,@(align-program (subprogram-prog x)
375 (addr+ addr (subprogram-table x)))))
377 `((load-number ,(number->string x))))
381 `((load-symbol ,(symbol->string x))))
383 `((load-keyword ,(symbol->string (keyword->symbol x)))))
385 (let ((tail (let ((len (length x)))
386 (if (>= len 65536) (too-long "list"))
387 `((list ,(quotient len 256) ,(modulo len 256))))))
388 (let dump-objects ((objects x) (codes '()) (addr addr))
390 (fold append tail codes)
391 (let ((code (dump-object (car objects) addr)))
392 (dump-objects (cdr objects) (cons code codes)
393 (addr+ addr code)))))))
395 (let ((kar (dump-object (car x) addr)))
397 ,@(dump-object (cdr x) (addr+ addr kar))
400 (let* ((len (vector-length x))
401 (tail (if (>= len 65536)
403 `((vector ,(quotient len 256) ,(modulo len 256))))))
404 (let dump-objects ((i 0) (codes '()) (addr addr))
406 (fold append tail codes)
407 (let ((code (dump-object (vector-ref x i) addr)))
408 (dump-objects (1+ i) (cons code codes)
409 (addr+ addr code)))))))
410 ((and (array? x) (symbol? (array-type x)))
411 (let* ((type (dump-object (array-type x) addr))
412 (shape (dump-object (array-shape x) (addr+ addr type))))
416 `(load-array ,(uniform-array->bytevector x))
417 (addr+ (addr+ addr type) shape)
421 (error "assemble: unrecognized object" x))))