;; Copyright (C) 2001, 2009 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.
+;;;; 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
((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 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 -1)
+ (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
- (addr+ 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 (align-program prog addr)))
- (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 ,@(align-program prog (addr+ addr table))
- ,@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 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
((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)))))
- ((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))))))
- (if (< x 0)
- `((load-integer ,str))
- `((load-unsigned-integer ,str)))))
+ (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)
(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