;;; Guile VM assembler
-;; Copyright (C) 2001 Free Software Foundation, Inc.
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
#:use-module ((system vm program) #:select (make-binding))
#:use-module (ice-9 receive)
#:use-module ((srfi srfi-1) #:select (fold))
+ #:use-module (rnrs bytevector)
#:export (compile-assembly))
;; Variable cache cells go in the object table, and serialize as their
(define-record <variable-cache-cell> key)
;; Subprograms can be loaded into an object table as well. We need a
-;; disjoint type here too.
+;; disjoint type here too. (Subprograms have their own object tables --
+;; though probably we should just make one table per compilation unit.)
-(define-record <subprogram> code)
+(define-record <subprogram> table prog)
-;; A metadata thunk has no object table, so it is very quick to load.
+(define (limn-sources sources)
+ (let lp ((in sources) (out '()) (filename #f))
+ (if (null? in)
+ (reverse! out)
+ (let ((addr (caar in))
+ (new-filename (assq-ref (cdar in ) 'filename))
+ (line (assq-ref (cdar in) 'line))
+ (column (assq-ref (cdar in) 'column)))
+ (cond
+ ((not (equal? new-filename filename))
+ (lp (cdr in)
+ `((,addr . (,line . ,column))
+ (filename . ,new-filename)
+ . ,out)
+ new-filename))
+ ((or (null? out) (not (equal? (cdar out) `(,line . ,column))))
+ (lp (cdr in)
+ `((,addr . (,line . ,column))
+ . ,out)
+ filename))
+ (else
+ (lp (cdr in) out filename)))))))
+
(define (make-meta bindings sources tail)
(if (and (null? bindings) (null? sources) (null? tail))
#f
- (make-subprogram
- ;; we need to prepend #f for the object table. This would have
- ;; even less overhead if we just appended the metadata-generating
- ;; instructions after the body of the program's code. A FIXME for
- ;; the future, eh.
- `((make-false)
- ,(compile-assembly
- (make-glil-program 0 0 0 0 '()
- (list
- (make-glil-const `(,bindings ,sources ,@tail))
- (make-glil-call 'return 0))))))))
+ (compile-assembly
+ (make-glil-program 0 0 0 0 '()
+ (list
+ (make-glil-const `(,bindings ,sources ,@tail))
+ (make-glil-call 'return 1))))))
;; A functional stack of names of live variables.
-(define (make-open-binding name ext? index)
- (list name ext? index))
+(define (make-open-binding name boxed? index)
+ (list name boxed? index))
(define (make-closed-binding open-binding start end)
(make-binding (car open-binding) (cadr open-binding)
(caddr open-binding) start end))
-(define (open-binding bindings vars nargs start)
+(define (open-binding bindings vars start)
(cons
(acons start
(map
(lambda (v)
(pmatch v
- ((,name argument ,i) (make-open-binding name #f i))
- ((,name local ,i) (make-open-binding name #f (+ nargs i)))
- ((,name external ,i) (make-open-binding name #t i))
- (else (error "unknown binding type" name type))))
+ ((,name ,boxed? ,i)
+ (make-open-binding name boxed? i))
+ (else (error "unknown binding type" v))))
vars)
(car bindings))
(cdr bindings)))
(close-all-bindings (close-binding bindings end) end)))
;; A functional object table.
-(define *module-and-meta* 2)
+(define *module* 1)
(define (assoc-ref-or-acons alist x make-y)
(cond ((assoc-ref alist x)
=> (lambda (y) (values y alist)))
(define (object-index-and-alist x alist)
(assoc-ref-or-acons alist x
(lambda (x alist)
- (+ (length alist) *module-and-meta*))))
+ (+ (length alist) *module*))))
(define (compile-assembly glil)
(receive (code . _)
- (glil->assembly glil 0 '() '(()) '() '() #f 0)
+ (glil->assembly glil '() '(()) '() '() #f -1)
(car code)))
-(define (make-object-table objects meta)
- (and (or meta (not (null? objects)))
- (list->vector (cons* #f meta objects))))
+(define (make-object-table objects)
+ (and (not (null? objects))
+ (list->vector (cons #f objects))))
-(define (glil->assembly glil nargs nexts-stack bindings
+(define (glil->assembly glil nexts-stack bindings
source-alist label-alist object-alist addr)
(define (emit-code x)
- (values x bindings source-alist label-alist object-alist))
+ (values (map assembly-pack x) bindings source-alist label-alist object-alist))
(define (emit-code/object x object-alist)
- (values x bindings source-alist label-alist object-alist))
+ (values (map assembly-pack x) bindings source-alist label-alist object-alist))
(record-case glil
((<glil-program> nargs nrest nlocs nexts meta body closure-level)
((null? body)
(values (reverse code)
(close-all-bindings bindings addr)
- (reverse source-alist)
+ (limn-sources (reverse! source-alist))
(reverse label-alist)
(and object-alist (map car (reverse object-alist)))
addr))
(else
(receive (subcode bindings source-alist label-alist object-alist)
- (glil->assembly (car body) nargs nexts-stack bindings
+ (glil->assembly (car body) nexts-stack bindings
source-alist label-alist object-alist addr)
(lp (cdr body) (append (reverse subcode) code)
bindings source-alist label-alist object-alist
- (apply + addr (map byte-length subcode)))))))))
+ (addr+ addr subcode))))))))
(receive (code bindings sources labels objects len)
(process-body)
(let ((prog `(load-program ,nargs ,nrest ,nlocs ,nexts ,labels
- ,len . ,code)))
+ ,len
+ ,(make-meta bindings sources meta)
+ . ,code)))
(cond
(toplevel?
;; toplevel bytecode isn't loaded by the vm, no way to do
;; object table or closure capture (not in the bytecode,
;; anyway)
- (emit-code `(,prog)))
+ (emit-code (align-program prog addr)))
(else
- (let ((table (dump-object (make-object-table
- objects
- (make-meta bindings sources meta))
- addr))
+ (let ((table (dump-object (make-object-table objects) addr))
(closure (if (> closure-level 0) '((make-closure)) '())))
(cond
(object-alist
;; if we are being compiled from something with an object
;; table, cache the program there
(receive (i object-alist)
- (object-index-and-alist (make-subprogram `(,@table ,prog))
+ (object-index-and-alist (make-subprogram table prog)
object-alist)
- (emit-code/object `((object-ref ,i) ,@closure)
+ (emit-code/object `(,(if (< i 256)
+ `(object-ref ,i)
+ `(long-object-ref ,(quotient i 256)
+ ,(modulo i 256)))
+ ,@closure)
object-alist)))
(else
;; otherwise emit a load directly
- (emit-code `(,@table ,prog ,@closure)))))))))))
+ (emit-code `(,@table ,@(align-program prog (addr+ addr table))
+ ,@closure)))))))))))
((<glil-bind> vars)
(values '()
- (open-binding bindings vars nargs addr)
+ (open-binding bindings vars addr)
source-alist
label-alist
object-alist))
((<glil-mv-bind> vars rest)
(values `((truncate-values ,(length vars) ,(if rest 1 0)))
- (open-binding bindings vars nargs addr)
+ (open-binding bindings vars addr)
source-alist
label-alist
object-alist))
label-alist
object-alist))
- ((<glil-source> loc)
+ ((<glil-source> props)
(values '()
bindings
- (acons addr loc source-alist)
+ (acons addr props source-alist)
label-alist
object-alist))
(else
(receive (i object-alist)
(object-index-and-alist obj object-alist)
- (emit-code/object `((object-ref ,i))
+ (emit-code/object (if (< i 256)
+ `((object-ref ,i))
+ `((long-object-ref ,(quotient i 256)
+ ,(modulo i 256))))
object-alist)))))
- ((<glil-argument> op index)
+ ((<glil-local> op index)
(emit-code (if (eq? op 'ref)
`((local-ref ,index))
`((local-set ,index)))))
- ((<glil-local> op index)
- (emit-code (if (eq? op 'ref)
- `((local-ref ,(+ nargs index)))
- `((local-set ,(+ nargs index))))))
-
((<glil-external> op depth index)
(emit-code (let lp ((d depth) (n 0) (stack nexts-stack))
(if (> d 0)
`((external-ref ,(+ n index)))
`((external-set ,(+ n index))))))))
+ ((<glil-lexical> local? boxed? op index)
+ (emit-code
+ `((,(if local?
+ (case op
+ ((ref) (if boxed? 'local-boxed-ref 'local-ref))
+ ((set) (if boxed? 'local-boxed-set 'local-set))
+ ((box) 'box)
+ ((empty-box) 'empty-box)
+ (else (error "what" op)))
+ (case op
+ ((ref) (if boxed? 'closure-boxed-ref 'closure-ref))
+ ((set) (if boxed? 'closure-boxed-set (error "what." glil)))
+ (else (error "what" op))))
+ ,index))))
+
((<glil-toplevel> op name)
(case op
((ref set)
(receive (i object-alist)
(object-index-and-alist (make-variable-cache-cell name)
object-alist)
- (emit-code/object (case op
- ((ref) `((toplevel-ref ,i)))
- ((set) `((toplevel-set ,i))))
+ (emit-code/object (if (< i 256)
+ `((,(case op
+ ((ref) 'toplevel-ref)
+ ((set) 'toplevel-set))
+ ,i))
+ `((,(case op
+ ((ref) 'long-toplevel-ref)
+ ((set) 'long-toplevel-set))
+ ,(quotient i 256)
+ ,(modulo i 256))))
object-alist)))))
((define)
(emit-code `((define ,(symbol->string name))
(error "Unknown instruction:" inst))
(let ((pops (instruction-pops inst)))
(cond ((< pops 0)
- (emit-code `((,inst ,nargs))))
+ (case (instruction-length inst)
+ ((1) (emit-code `((,inst ,nargs))))
+ ((2) (emit-code `((,inst ,(quotient nargs 256)
+ ,(modulo nargs 256)))))
+ (else (error "Unknown length for variable-arg instruction:"
+ inst (instruction-length inst)))))
((= pops nargs)
(emit-code `((,inst))))
(else
((<glil-mv-call> nargs ra)
(emit-code `((mv-call ,nargs ,ra))))))
-;; addr is currently unused, but could be used to align data in the
-;; instruction stream.
(define (dump-object x addr)
(define (too-long x)
(error (string-append x " too long")))
- (let dump ((x x))
- (cond
- ((object->assembly x) => list)
- ((variable-cache-cell? x) (dump (variable-cache-cell-key x)))
- ((subprogram? x) (subprogram-code x))
- ((and (integer? x) (exact? x))
- (let ((str (do ((n x (quotient n 256))
- (l '() (cons (modulo n 256) l)))
- ((= n 0)
- (list->string (map integer->char l))))))
- `((load-integer ,str))))
- ((number? x)
- `((load-number ,(number->string x))))
- ((string? x)
- `((load-string ,x)))
- ((symbol? x)
- `((load-symbol ,(symbol->string x))))
- ((keyword? x)
- `((load-keyword ,(symbol->string (keyword->symbol x)))))
- ((list? x)
- (fold append
- (let ((len (length x)))
- (if (>= len 65536) (too-long "list"))
- `((list ,(quotient len 256) ,(modulo len 256))))
- (fold (lambda (x y) (cons (dump x) y))
- '()
- x)))
- ((pair? x)
- `(,@(dump (car x))
- ,@(dump (cdr x))
- (cons)))
- ((vector? x)
- (fold append
- (let ((len (vector-length x)))
- (if (>= len 65536) (too-long "vector"))
- `((vector ,(quotient len 256) ,(modulo len 256))))
- (fold (lambda (x y) (cons (dump x) y))
- '()
- (vector->list x))))
- (else
- (error "assemble: unrecognized object" x)))))
+ (cond
+ ((object->assembly x) => list)
+ ((variable-cache-cell? x) (dump-object (variable-cache-cell-key x) addr))
+ ((subprogram? x)
+ `(,@(subprogram-table x)
+ ,@(align-program (subprogram-prog x)
+ (addr+ addr (subprogram-table x)))))
+ ((number? x)
+ `((load-number ,(number->string x))))
+ ((string? x)
+ `((load-string ,x)))
+ ((symbol? x)
+ `((load-symbol ,(symbol->string x))))
+ ((keyword? x)
+ `((load-keyword ,(symbol->string (keyword->symbol x)))))
+ ((list? x)
+ (let ((tail (let ((len (length x)))
+ (if (>= len 65536) (too-long "list"))
+ `((list ,(quotient len 256) ,(modulo len 256))))))
+ (let dump-objects ((objects x) (codes '()) (addr addr))
+ (if (null? objects)
+ (fold append tail codes)
+ (let ((code (dump-object (car objects) addr)))
+ (dump-objects (cdr objects) (cons code codes)
+ (addr+ addr code)))))))
+ ((pair? x)
+ (let ((kar (dump-object (car x) addr)))
+ `(,@kar
+ ,@(dump-object (cdr x) (addr+ addr kar))
+ (cons))))
+ ((vector? x)
+ (let* ((len (vector-length x))
+ (tail (if (>= len 65536)
+ (too-long "vector")
+ `((vector ,(quotient len 256) ,(modulo len 256))))))
+ (let dump-objects ((i 0) (codes '()) (addr addr))
+ (if (>= i len)
+ (fold append tail codes)
+ (let ((code (dump-object (vector-ref x i) addr)))
+ (dump-objects (1+ i) (cons code codes)
+ (addr+ addr code)))))))
+ ((and (array? x) (symbol? (array-type x)))
+ (let* ((type (dump-object (array-type x) addr))
+ (shape (dump-object (array-shape x) (addr+ addr type))))
+ `(,@type
+ ,@shape
+ ,@(align-code
+ `(load-array ,(uniform-array->bytevector x))
+ (addr+ (addr+ addr type) shape)
+ 8
+ 4))))
+ (else
+ (error "assemble: unrecognized object" x))))
HCoop / bpt / guile.git / blobdiff