3 ;; Copyright (C) 2001, 2009 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 compile-assembly)
23 #:use-module (system base syntax)
24 #:use-module (system base pmatch)
25 #:use-module (language glil)
26 #:use-module (language assembly)
27 #:use-module (system vm instruction)
28 #:use-module ((system vm program) #:select (make-binding))
29 #:use-module (ice-9 receive)
30 #:use-module ((srfi srfi-1) #:select (fold))
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 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 ext? index)
82 (list name ext? 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 nargs start)
92 ((,name argument ,i) (make-open-binding name #f i))
93 ((,name local ,i) (make-open-binding name #f (+ nargs i)))
94 ((,name external ,i) (make-open-binding name #t i))
95 (else (error "unknown binding type" name type))))
99 (define (close-binding bindings end)
101 ((((,start . ,closing) . ,open) . ,closed)
103 (fold (lambda (o tail)
104 ;; the cons is for dsu sort
105 (acons start (make-closed-binding o start end)
109 (else (error "broken bindings" bindings))))
110 (define (close-all-bindings bindings end)
111 (if (null? (car bindings))
113 (stable-sort (reverse (cdr bindings))
114 (lambda (x y) (< (car x) (car y)))))
115 (close-all-bindings (close-binding bindings end) end)))
117 ;; A functional object table.
119 (define (assoc-ref-or-acons alist x make-y)
120 (cond ((assoc-ref alist x)
121 => (lambda (y) (values y alist)))
123 (let ((y (make-y x alist)))
124 (values y (acons x y alist))))))
125 (define (object-index-and-alist x alist)
126 (assoc-ref-or-acons alist x
128 (+ (length alist) *module*))))
130 (define (compile-assembly glil)
132 (glil->assembly glil 0 '() '(()) '() '() #f -1)
134 (define (make-object-table objects)
135 (and (not (null? objects))
136 (list->vector (cons #f objects))))
138 (define (glil->assembly glil nargs nexts-stack bindings
139 source-alist label-alist object-alist addr)
140 (define (emit-code x)
141 (values (map assembly-pack x) bindings source-alist label-alist object-alist))
142 (define (emit-code/object x object-alist)
143 (values (map assembly-pack x) bindings source-alist label-alist object-alist))
146 ((<glil-program> nargs nrest nlocs nexts meta body closure-level)
147 (let ((toplevel? (null? nexts-stack)))
148 (define (process-body)
149 (let ((nexts-stack (cons nexts nexts-stack)))
150 (let lp ((body body) (code '()) (bindings '(())) (source-alist '())
151 (label-alist '()) (object-alist (if toplevel? #f '())) (addr 0))
154 (values (reverse code)
155 (close-all-bindings bindings addr)
156 (limn-sources (reverse! source-alist))
157 (reverse label-alist)
158 (and object-alist (map car (reverse object-alist)))
161 (receive (subcode bindings source-alist label-alist object-alist)
162 (glil->assembly (car body) nargs nexts-stack bindings
163 source-alist label-alist object-alist addr)
164 (lp (cdr body) (append (reverse subcode) code)
165 bindings source-alist label-alist object-alist
166 (addr+ addr subcode))))))))
168 (receive (code bindings sources labels objects len)
170 (let ((prog `(load-program ,nargs ,nrest ,nlocs ,nexts ,labels
172 ,(make-meta bindings sources meta)
176 ;; toplevel bytecode isn't loaded by the vm, no way to do
177 ;; object table or closure capture (not in the bytecode,
179 (emit-code (align-program prog addr)))
181 (let ((table (dump-object (make-object-table objects) addr))
182 (closure (if (> closure-level 0) '((make-closure)) '())))
185 ;; if we are being compiled from something with an object
186 ;; table, cache the program there
187 (receive (i object-alist)
188 (object-index-and-alist (make-subprogram table prog)
190 (emit-code/object `((object-ref ,i) ,@closure)
193 ;; otherwise emit a load directly
194 (emit-code `(,@table ,@(align-program prog (addr+ addr table))
199 (open-binding bindings vars nargs addr)
204 ((<glil-mv-bind> vars rest)
205 (values `((truncate-values ,(length vars) ,(if rest 1 0)))
206 (open-binding bindings vars nargs addr)
213 (close-binding bindings addr)
218 ((<glil-source> props)
221 (acons addr props source-alist)
226 (emit-code '((void))))
230 ((object->assembly obj)
232 (emit-code (list code))))
234 (emit-code (dump-object obj addr)))
236 (receive (i object-alist)
237 (object-index-and-alist obj object-alist)
238 (emit-code/object `((object-ref ,i))
241 ((<glil-argument> op index)
242 (emit-code (if (eq? op 'ref)
243 `((local-ref ,index))
244 `((local-set ,index)))))
246 ((<glil-local> op index)
247 (emit-code (if (eq? op 'ref)
248 `((local-ref ,(+ nargs index)))
249 `((local-set ,(+ nargs index))))))
251 ((<glil-external> op depth index)
252 (emit-code (let lp ((d depth) (n 0) (stack nexts-stack))
254 (lp (1- d) (+ n (car stack)) (cdr stack))
256 `((external-ref ,(+ n index)))
257 `((external-set ,(+ n index))))))))
259 ((<glil-toplevel> op name)
264 (emit-code `(,@(dump-object name addr)
267 ((ref) '(variable-ref))
268 ((set) '(variable-set))))))
270 (receive (i object-alist)
271 (object-index-and-alist (make-variable-cache-cell name)
273 (emit-code/object (case op
274 ((ref) `((toplevel-ref ,i)))
275 ((set) `((toplevel-set ,i))))
278 (emit-code `((define ,(symbol->string name))
281 (error "unknown toplevel var kind" op name))))
283 ((<glil-module> op mod name public?)
284 (let ((key (list mod name public?)))
289 (emit-code `(,@(dump-object key addr)
292 ((ref) '(variable-ref))
293 ((set) '(variable-set))))))
295 (receive (i object-alist)
296 (object-index-and-alist (make-variable-cache-cell key)
298 (emit-code/object (case op
299 ((ref) `((toplevel-ref ,i)))
300 ((set) `((toplevel-set ,i))))
303 (error "unknown module var kind" op key)))))
305 ((<glil-label> label)
309 (acons label addr label-alist)
312 ((<glil-branch> inst label)
313 (emit-code `((,inst ,label))))
315 ;; nargs is number of stack args to insn. probably should rename.
316 ((<glil-call> inst nargs)
317 (if (not (instruction? inst))
318 (error "Unknown instruction:" inst))
319 (let ((pops (instruction-pops inst)))
321 (emit-code `((,inst ,nargs))))
323 (emit-code `((,inst))))
325 (error "Wrong number of stack arguments to instruction:" inst nargs)))))
327 ((<glil-mv-call> nargs ra)
328 (emit-code `((mv-call ,nargs ,ra))))))
330 (define (dump-object x addr)
332 (error (string-append x " too long")))
335 ((object->assembly x) => list)
336 ((variable-cache-cell? x) (dump-object (variable-cache-cell-key x) addr))
338 `(,@(subprogram-table x)
339 ,@(align-program (subprogram-prog x)
340 (addr+ addr (subprogram-table x)))))
341 ((and (integer? x) (exact? x))
342 (let ((str (do ((n x (quotient n 256))
343 (l '() (cons (modulo n 256) l)))
345 (list->string (map integer->char l))))))
347 `((load-integer ,str))
348 `((load-unsigned-integer ,str)))))
350 `((load-number ,(number->string x))))
354 `((load-symbol ,(symbol->string x))))
356 `((load-keyword ,(symbol->string (keyword->symbol x)))))
358 (let ((tail (let ((len (length x)))
359 (if (>= len 65536) (too-long "list"))
360 `((list ,(quotient len 256) ,(modulo len 256))))))
361 (let dump-objects ((objects x) (codes '()) (addr addr))
363 (fold append tail codes)
364 (let ((code (dump-object (car objects) addr)))
365 (dump-objects (cdr objects) (cons code codes)
366 (addr+ addr code)))))))
368 (let ((kar (dump-object (car x) addr)))
370 ,@(dump-object (cdr x) (addr+ addr kar))
373 (let* ((len (vector-length x))
374 (tail (if (>= len 65536)
376 `((vector ,(quotient len 256) ,(modulo len 256))))))
377 (let dump-objects ((i 0) (codes '()) (addr addr))
379 (fold append tail codes)
380 (let ((code (dump-object (vector-ref x i) addr)))
381 (dump-objects (1+ i) (cons code codes)
382 (addr+ addr code)))))))
384 (error "assemble: unrecognized object" x))))