mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-14 17:50:22 +02:00
d51406fe87
* libguile/vm-engine.c (vm_run): Add new error case, vm_error_not_enough_values. * libguile/vm-i-system.c (goto/nargs, call/nargs): So, in these cases, if we get too many values, we don't truncate the values like we do in the single-value continuation case, or in the mvbind case. What to do? I guess we either truncate them here, or only allow the correct number of values. Dunno. Mark the code as a fixme. (truncate-values): New instruction, for mv-bind: checks that the number of values on the stack is compatible with the number of bindings we have arranged for them, truncating if necessary. * module/language/scheme/translate.scm (custom-transformer-table): Compile receive as a primary form -- not so much because it is a primary form, but more to test the mv-bind machinery. Also it's more efficient, I think. * module/system/il/compile.scm (lift-variables!): New helper, factored out of `optimize'. (optimize): Add a few more cases. Adapt `lambda' optimization, which isn't much. I'm not happy with ghil as a mungeable language. Add a case for call-with-values with the second argument is a lambda: lift the lambda. Untested. (codegen): Refactor the push-bindings! code. Compile mv-bind. * module/system/il/ghil.scm (<ghil-mv-bind>): Add mv-bind construct, along with its procedures. * module/system/il/glil.scm (<glil-mv-bind>): Add mv-bind construct, different from the high-level one. It makes sense in the source, I think. * module/system/vm/assemble.scm (codegen): Assemble glil-mv-bind by pushing onto the bindings list, and actually push some code to truncate the values.
361 lines
12 KiB
Scheme
361 lines
12 KiB
Scheme
;;; 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.
|
||
|
||
;;; Code:
|
||
|
||
(define-module (system vm assemble)
|
||
#:use-syntax (system base syntax)
|
||
#:use-module (system il glil)
|
||
#:use-module (system vm instruction)
|
||
#:use-module (system vm objcode)
|
||
#:use-module ((system vm program) #:select (make-binding))
|
||
#:use-module (system vm conv)
|
||
#:use-module (ice-9 regex)
|
||
#:use-module (ice-9 common-list)
|
||
#:use-module (srfi srfi-4)
|
||
#:use-module ((srfi srfi-1) #:select (append-map))
|
||
#:export (preprocess codegen assemble))
|
||
|
||
(define (assemble glil env . opts)
|
||
(codegen (preprocess glil #f) #t))
|
||
|
||
|
||
;;;
|
||
;;; Types
|
||
;;;
|
||
|
||
(define-record (<vm-asm> venv glil body))
|
||
(define-record (<venv> parent nexts closure?))
|
||
(define-record (<vlink-now> name))
|
||
(define-record (<vlink-later> module name))
|
||
(define-record (<vdefine> module name))
|
||
(define-record (<bytespec> vars bytes meta objs closure?))
|
||
|
||
|
||
;;;
|
||
;;; Stage 1: Preprocess
|
||
;;;
|
||
|
||
(define (preprocess x e)
|
||
(record-case x
|
||
((<glil-asm> vars meta body)
|
||
(let* ((venv (make-venv #:parent e #:nexts (glil-vars-nexts vars) #:closure? #f))
|
||
(body (map (lambda (x) (preprocess x venv)) body)))
|
||
(make-vm-asm #:venv venv #:glil x #:body body)))
|
||
((<glil-external> op depth index)
|
||
(do ((d depth (- d 1))
|
||
(e e (venv-parent e)))
|
||
((= d 0))
|
||
(set! (venv-closure? e) #t))
|
||
x)
|
||
(else x)))
|
||
|
||
|
||
;;;
|
||
;;; Stage 2: Bytecode generation
|
||
;;;
|
||
|
||
(define-macro (push x loc)
|
||
`(set! ,loc (cons ,x ,loc)))
|
||
|
||
;; this is to avoid glil-const's desire to put constants in the object
|
||
;; array -- instead we explicitly want them in the code, because meta
|
||
;; info is infrequently used. to load it up always would make garbage,
|
||
;; needlessly. so hide it behind a lambda.
|
||
(define (make-meta bindings sources tail)
|
||
(if (and (null? bindings) (null? sources) (null? tail))
|
||
#f
|
||
(let ((stack '()))
|
||
(define (push-code! code)
|
||
(push (code->bytes code) stack))
|
||
(dump-object! push-code! `(,bindings ,sources ,@tail))
|
||
(push-code! '(return))
|
||
(make-bytespec #:vars (make-glil-vars 0 0 0 0)
|
||
#:bytes (stack->bytes (reverse! stack) '())
|
||
#:meta #f #:objs #f #:closure? #f))))
|
||
|
||
(define (byte-length x)
|
||
(cond ((u8vector? x) (u8vector-length x))
|
||
((>= (instruction-length (car x)) 0)
|
||
;; one byte for the instruction itself
|
||
(1+ (instruction-length (car x))))
|
||
(else (error "variable-length instruction?" x))))
|
||
|
||
(define (codegen glil toplevel)
|
||
(record-case glil
|
||
((<vm-asm> venv glil body) (record-case glil ((<glil-asm> vars meta) ; body?
|
||
(let ((stack '())
|
||
(binding-alist '())
|
||
(source-alist '())
|
||
(label-alist '())
|
||
(object-alist '()))
|
||
(define (push-code! code)
|
||
; (format #t "push-code! ~a~%" code)
|
||
(push (code->bytes code) stack))
|
||
(define (push-object! x)
|
||
(cond ((object->code x) => push-code!)
|
||
(toplevel
|
||
(dump-object! push-code! x))
|
||
(else
|
||
(let ((i (cond ((object-assoc x object-alist) => cdr)
|
||
(else
|
||
(let ((i (length object-alist)))
|
||
(set! object-alist (acons x i object-alist))
|
||
i)))))
|
||
(push-code! `(object-ref ,i))))))
|
||
(define (current-address)
|
||
(apply + (map byte-length stack)))
|
||
(define (generate-code x)
|
||
(record-case x
|
||
((<vm-asm> venv)
|
||
(push-object! (codegen x #f))
|
||
(if (venv-closure? venv) (push-code! `(make-closure))))
|
||
|
||
((<glil-bind> (binds vars))
|
||
(let ((bindings
|
||
(map (lambda (v)
|
||
(let ((name (car v)) (type (cadr v)) (i (caddr v)))
|
||
(case type
|
||
((argument) (make-binding name #f i))
|
||
((local) (make-binding name #f (+ (glil-vars-nargs vars) i)))
|
||
((external) (make-binding name #t i)))))
|
||
binds)))
|
||
(set! binding-alist
|
||
(acons (current-address) bindings binding-alist))))
|
||
|
||
((<glil-mv-bind> (binds vars) rest)
|
||
(let ((bindings
|
||
(map (lambda (v)
|
||
(let ((name (car v)) (type (cadr v)) (i (caddr v)))
|
||
(case type
|
||
((argument) (make-binding name #f i))
|
||
((local) (make-binding name #f (+ (glil-vars-nargs vars) i)))
|
||
((external) (make-binding name #t i)))))
|
||
binds)))
|
||
(set! binding-alist
|
||
(acons (current-address) bindings binding-alist))
|
||
(push-code! `(truncate-values ,(length binds) ,(if rest 1 0)))))
|
||
|
||
((<glil-unbind>)
|
||
(set! binding-alist (acons (current-address) #f binding-alist)))
|
||
|
||
((<glil-source> loc)
|
||
(set! source-alist (acons (current-address) loc source-alist)))
|
||
|
||
((<glil-void>)
|
||
(push-code! '(void)))
|
||
|
||
((<glil-const> obj)
|
||
(push-object! obj))
|
||
|
||
((<glil-argument> op index)
|
||
(if (eq? op 'ref)
|
||
(push-code! `(local-ref ,index))
|
||
(push-code! `(local-set ,index))))
|
||
|
||
((<glil-local> op index)
|
||
(if (eq? op 'ref)
|
||
(push-code! `(local-ref ,(+ (glil-vars-nargs vars) index)))
|
||
(push-code! `(local-set ,(+ (glil-vars-nargs vars) index)))))
|
||
|
||
((<glil-external> op depth index)
|
||
(do ((e venv (venv-parent e))
|
||
(d depth (1- d))
|
||
(n 0 (+ n (venv-nexts e))))
|
||
((= d 0)
|
||
(if (eq? op 'ref)
|
||
(push-code! `(external-ref ,(+ n index)))
|
||
(push-code! `(external-set ,(+ n index)))))))
|
||
|
||
((<glil-module> op module name)
|
||
(case op
|
||
((ref set)
|
||
(cond
|
||
(toplevel
|
||
(push-object! (make-vlink-now #:name name))
|
||
(push-code! (case op
|
||
((ref) '(variable-ref))
|
||
((set) '(variable-set)))))
|
||
(else
|
||
(let* ((var (make-vlink-later #:module module #:name name))
|
||
(i (cond ((object-assoc var object-alist) => cdr)
|
||
(else
|
||
(let ((i (length object-alist)))
|
||
(set! object-alist (acons var i object-alist))
|
||
i)))))
|
||
(push-code! (case op
|
||
((ref) `(late-variable-ref ,i))
|
||
((set) `(late-variable-set ,i))))))))
|
||
((define)
|
||
(push-object! (make-vdefine #:module module #:name name))
|
||
(push-code! '(variable-set)))
|
||
(else
|
||
(error "unknown toplevel var kind" op name))))
|
||
|
||
((<glil-label> label)
|
||
(set! label-alist (assq-set! label-alist label (current-address))))
|
||
|
||
((<glil-branch> inst label)
|
||
(push (list inst label) stack))
|
||
|
||
((<glil-call> inst nargs)
|
||
(if (instruction? inst)
|
||
(let ((pops (instruction-pops inst)))
|
||
(cond ((< pops 0)
|
||
(push-code! (list inst nargs)))
|
||
((= pops nargs)
|
||
(push-code! (list inst)))
|
||
(else
|
||
(error "Wrong number of arguments:" inst nargs))))
|
||
(error "Unknown instruction:" inst)))
|
||
|
||
((<glil-mv-call> nargs ra)
|
||
(push (list 'mv-call nargs ra) stack))))
|
||
|
||
;;
|
||
;; main
|
||
(for-each generate-code body)
|
||
; (format #t "codegen: stack = ~a~%" (reverse stack))
|
||
(let ((bytes (stack->bytes (reverse! stack) label-alist)))
|
||
(if toplevel
|
||
(bytecode->objcode bytes (glil-vars-nlocs vars) (glil-vars-nexts vars))
|
||
(make-bytespec #:vars vars #:bytes bytes
|
||
#:meta (make-meta (reverse! binding-alist)
|
||
(reverse! source-alist)
|
||
meta)
|
||
#:objs (let ((objs (map car (reverse! object-alist))))
|
||
(if (null? objs) #f (list->vector objs)))
|
||
#:closure? (venv-closure? venv))))))))))
|
||
|
||
(define (object-assoc x alist)
|
||
(record-case x
|
||
((<vlink-now>) (assoc x alist))
|
||
((<vlink-later>) (assoc x alist))
|
||
(else (assq x alist))))
|
||
|
||
(define (check-length len u8v)
|
||
(or (= len (u8vector-length u8v))
|
||
(error "the badness!" len u8v))
|
||
u8v)
|
||
|
||
(define (stack->bytes stack label-alist)
|
||
(let loop ((result '()) (stack stack) (addr 0))
|
||
(if (null? stack)
|
||
(check-length
|
||
addr
|
||
(list->u8vector
|
||
(append-map u8vector->list (reverse! result))))
|
||
(let ((elt (car stack)))
|
||
(cond
|
||
((u8vector? elt)
|
||
(loop (cons elt result)
|
||
(cdr stack)
|
||
(+ addr (byte-length elt))))
|
||
((symbol? (car (last-pair elt)))
|
||
;; not yet code because labels needed to be resolved
|
||
(let* ((head (list-head elt (1- (length elt))))
|
||
(label-addr (assq-ref label-alist (car (last-pair elt))))
|
||
(offset (- label-addr (+ addr (byte-length elt))))
|
||
(n (if (< offset 0) (+ offset 65536) offset)))
|
||
(loop (cons (code->bytes
|
||
(append head (list (quotient n 256) (modulo n 256))))
|
||
result)
|
||
(cdr stack)
|
||
(+ addr (byte-length elt)))))
|
||
(else (error "bad code" elt)))))))
|
||
|
||
|
||
;;;
|
||
;;; Object dump
|
||
;;;
|
||
|
||
;; NOTE: undumpped in vm_system.c
|
||
|
||
(define (dump-object! push-code! x)
|
||
(define (too-long x)
|
||
(error (string-append x " too long")))
|
||
|
||
(let dump! ((x x))
|
||
(cond
|
||
((object->code x) => push-code!)
|
||
((record? x)
|
||
(record-case x
|
||
((<bytespec> vars bytes meta objs closure?)
|
||
;; dump parameters
|
||
(let ((nargs (glil-vars-nargs vars)) (nrest (glil-vars-nrest vars))
|
||
(nlocs (glil-vars-nlocs vars)) (nexts (glil-vars-nexts vars)))
|
||
(cond
|
||
((and (< nargs 16) (< nlocs 128) (< nexts 16))
|
||
;; 16-bit representation
|
||
(let ((x (logior
|
||
(ash nargs 12) (ash nrest 11) (ash nlocs 4) nexts)))
|
||
(push-code! `(make-int16 ,(ash x -8) ,(logand x (1- (ash 1 8)))))))
|
||
(else
|
||
;; Other cases
|
||
(push-code! (object->code nargs))
|
||
(push-code! (object->code nrest))
|
||
(push-code! (object->code nlocs))
|
||
(push-code! (object->code nexts))
|
||
(push-code! (object->code #f)))))
|
||
;; dump object table
|
||
(if objs (dump! objs))
|
||
;; dump meta data
|
||
(if meta (dump! meta))
|
||
;; dump bytecode
|
||
(push-code! `(load-program ,bytes)))
|
||
((<vlink-later> module name)
|
||
(dump! name))
|
||
((<vlink-now> name)
|
||
(dump! name)
|
||
(push-code! '(link-now)))
|
||
((<vdefine> module name)
|
||
;; FIXME: dump module
|
||
(push-code! `(define ,(symbol->string name))))
|
||
(else
|
||
(error "assemble: unknown record type" (record-type-descriptor x)))))
|
||
((and (integer? x) (exact? x))
|
||
(let ((str (do ((n x (quotient n 256))
|
||
(l '() (cons (modulo n 256) l)))
|
||
((= n 0)
|
||
(apply u8vector l)))))
|
||
(push-code! `(load-integer ,str))))
|
||
((number? x)
|
||
(push-code! `(load-number ,(number->string x))))
|
||
((string? x)
|
||
(push-code! `(load-string ,x)))
|
||
((symbol? x)
|
||
(push-code! `(load-symbol ,(symbol->string x))))
|
||
((keyword? x)
|
||
(push-code! `(load-keyword ,(symbol->string (keyword->symbol x)))))
|
||
((list? x)
|
||
(for-each dump! x)
|
||
(let ((len (length x)))
|
||
(if (>= len 65536) (too-long 'list))
|
||
(push-code! `(list ,(quotient len 256) ,(modulo len 256)))))
|
||
((pair? x)
|
||
(dump! (car x))
|
||
(dump! (cdr x))
|
||
(push-code! `(cons)))
|
||
((vector? x)
|
||
(for-each dump! (vector->list x))
|
||
(let ((len (vector-length x)))
|
||
(if (>= len 65536) (too-long 'vector))
|
||
(push-code! `(vector ,(quotient len 256) ,(modulo len 256)))))
|
||
(else
|
||
(error "assemble: unrecognized object" x)))))
|