;; 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))))
(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 '() '(()) '() '() #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 nexts-stack bindings
source-alist label-alist object-alist addr)
(define (emit-code x)
(values (map assembly-pack x) bindings source-alist label-alist 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
(receive (i object-alist)
(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
((<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)
+ ((<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
`(,@(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)))))
((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