;;; 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)
(define (limn-sources sources)
((not (equal? new-filename filename))
(lp (cdr in)
`((,addr . (,line . ,column))
- (filename ,new-filename)
+ (filename . ,new-filename)
. ,out)
new-filename))
((or (null? out) (not (equal? (cdar out) `(,line . ,column))))
(if (and (null? bindings) (null? sources) (null? tail))
#f
(compile-assembly
- (make-glil-program 0 0 0 0 '()
+ (make-glil-program 0 0 0 '()
(list
(make-glil-const `(,bindings ,sources ,@tail))
- (make-glil-call 'return 0))))))
+ (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)))
(define (compile-assembly glil)
(receive (code . _)
- (glil->assembly glil 0 '() '(()) '() '() #f 0)
+ (glil->assembly glil #t '(()) '() '() #f -1)
(car code)))
(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 toplevel? bindings
source-alist label-alist object-alist addr)
(define (emit-code x)
- (values (map assembly-pack x) bindings source-alist label-alist object-alist))
+ (values x bindings source-alist label-alist object-alist))
(define (emit-code/object x object-alist)
- (values (map assembly-pack x) bindings source-alist label-alist object-alist))
+ (values x bindings source-alist label-alist object-alist))
(record-case glil
- ((<glil-program> nargs nrest nlocs nexts meta body closure-level)
- (let ((toplevel? (null? nexts-stack)))
- (define (process-body)
- (let ((nexts-stack (cons nexts nexts-stack)))
- (let lp ((body body) (code '()) (bindings '(())) (source-alist '())
- (label-alist '()) (object-alist (if toplevel? #f '())) (addr 0))
+ ((<glil-program> nargs nrest nlocs meta body)
+ (define (process-body)
+ (let lp ((body body) (code '()) (bindings '(())) (source-alist '())
+ (label-alist '()) (object-alist (if toplevel? #f '())) (addr 0))
+ (cond
+ ((null? body)
+ (values (reverse code)
+ (close-all-bindings bindings addr)
+ (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) #f bindings
+ source-alist label-alist object-alist addr)
+ (lp (cdr body) (append (reverse subcode) code)
+ bindings source-alist label-alist object-alist
+ (addr+ addr subcode)))))))
+
+ (receive (code bindings sources labels objects len)
+ (process-body)
+ (let* ((meta (make-meta bindings sources meta))
+ (meta-pad (if meta (modulo (- 8 (modulo len 8)) 8) 0))
+ (prog `(load-program ,nargs ,nrest ,nlocs ,labels
+ ,(+ len meta-pad)
+ ,meta
+ ,@code
+ ,@(if meta
+ (make-list meta-pad '(nop))
+ '()))))
+ (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 (align-program prog addr)))
+ (else
+ (let ((table (make-object-table objects)))
(cond
- ((null? body)
- (values (reverse code)
- (close-all-bindings bindings addr)
- (limn-sources (reverse! source-alist))
- (reverse label-alist)
- (and object-alist (map car (reverse object-alist)))
- addr))
+ (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-alist)
+ (emit-code/object `(,(if (< i 256)
+ `(object-ref ,i)
+ `(long-object-ref ,(quotient i 256)
+ ,(modulo i 256))))
+ object-alist)))
(else
- (receive (subcode bindings source-alist label-alist object-alist)
- (glil->assembly (car body) nargs nexts-stack bindings
- source-alist label-alist object-alist addr)
- (lp (cdr body) (append (reverse subcode) code)
- bindings source-alist label-alist object-alist
- (fold (lambda (x len) (+ (byte-length x) len))
- addr subcode))))))))
-
- (receive (code bindings sources labels objects len)
- (process-body)
- (let ((prog `(load-program ,nargs ,nrest ,nlocs ,nexts ,labels
- ,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)))
- (else
- (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-alist)
- (emit-code/object `((object-ref ,i) ,@closure)
- object-alist)))
- (else
- ;; otherwise emit a load directly
- (emit-code `(,@table ,prog ,@closure)))))))))))
+ ;; otherwise emit a load directly
+ (let ((table-code (dump-object table addr)))
+ (emit-code
+ `(,@table-code
+ ,@(align-program prog (addr+ addr table-code)))))))))))))
((<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))
(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)
- (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)
- (lp (1- d) (+ n (car stack)) (cdr stack))
- (if (eq? op 'ref)
- `((external-ref ,(+ n index)))
- `((external-set ,(+ n index))))))))
-
+ ((<glil-lexical> local? boxed? op index)
+ (emit-code
+ (if local?
+ (if (< index 256)
+ `((,(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)))
+ ,index))
+ (let ((a (quotient i 256))
+ (b (modulo i 256)))
+ `((,(case op
+ ((ref)
+ (if boxed?
+ `((long-local-ref ,a ,b)
+ (variable-ref))
+ `((long-local-ref ,a ,b))))
+ ((set)
+ (if boxed?
+ `((long-local-ref ,a ,b)
+ (variable-set))
+ `((long-local-set ,a ,b))))
+ ((box)
+ `((make-variable)
+ (variable-set)
+ (long-local-set ,a ,b)))
+ ((empty-box)
+ `((make-variable)
+ (long-local-set ,a ,b)))
+ (else (error "what" op)))
+ ,index))))
+ `((,(case op
+ ((ref) (if boxed? 'free-boxed-ref 'free-ref))
+ ((set) (if boxed? 'free-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 module var kind" op key)))))
((<glil-label> label)
- (values '()
- bindings
- source-alist
- (acons label addr label-alist)
- object-alist))
+ (let ((code (align-block addr)))
+ (values code
+ bindings
+ source-alist
+ (acons label (addr+ addr code) label-alist)
+ object-alist)))
((<glil-branch> inst label)
(emit-code `((,inst ,label))))
(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)
+ (let ((table-code (dump-object (subprogram-table x) addr)))
+ `(,@table-code
+ ,@(align-program (subprogram-prog x)
+ (addr+ addr table-code)))))
+ ((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