+++ /dev/null
-;;; 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 (language glil compile-objcode)
- #:use-syntax (system base syntax)
- #:use-module (language 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 compile-objcode))
-
-(define (compile-objcode glil env . opts)
- (codegen (preprocess glil #f) #t))
-
-\f
-;;;
-;;; Types
-;;;
-
-(define-record <vm-asm> venv glil body)
-(define-record <venv> parent nexts closure?)
-;; key is either a symbol or the list (MODNAME SYM PUBLIC?)
-(define-record <vlink-now> key)
-(define-record <vlink-later> key)
-(define-record <vdefine> name)
-(define-record <bytespec> nargs nrest nlocs nexts bytes meta objs closure?)
-
-\f
-;;;
-;;; Stage 1: Preprocess
-;;;
-
-(define (preprocess x e)
- (record-case x
- ((<glil-program> nargs nrest nlocs nexts meta body)
- (let* ((venv (make-venv #:parent e #:nexts nexts #: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)))
-
-\f
-;;;
-;;; Stage 2: Bytecode generation
-;;;
-
-(define-macro (push x loc)
- `(set! ,loc (cons ,x ,loc)))
-(define-macro (pop loc)
- `(let ((_x (car ,loc))) (set! ,loc (cdr ,loc)) _x))
-
-;; 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 #:nargs 0 #:nrest 0 #:nlocs 0 #:nexts 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))))
-
-;; a binding that doesn't yet know its extents
-(define (make-temp-binding name ext? index)
- (list name ext? index))
-(define btemp:name car)
-(define btemp:extp cadr)
-(define btemp:index caddr)
-
-(define (codegen glil toplevel)
- (record-case glil
- ((<vm-asm> venv glil body) (record-case glil ((<glil-program> nargs nrest nlocs nexts meta) ; body?
- (let ((stack '())
- (open-bindings '())
- (closed-bindings '())
- (source-alist '())
- (label-alist '())
- ;; the pre-elements are prepended to the object vector in
- ;; practice these are placeholders for module & meta,
- ;; respectively.
- (object-pre-elements '(#f #f))
- (object-alist '()))
- (define (object-index obj)
- (cond ((object-assoc obj object-alist) => cdr)
- (else
- (let ((i (+ (length object-alist) (length object-pre-elements))))
- (set! object-alist (acons obj i object-alist))
- i))))
- (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
- (push-code! `(object-ref ,(object-index x))))))
- (define (munge-bindings bindings nargs)
- (map
- (lambda (v)
- (let ((name (car v)) (type (cadr v)) (i (caddr v)))
- (case type
- ((argument) (make-temp-binding name #f i))
- ((local) (make-temp-binding name #f (+ nargs i)))
- ((external) (make-temp-binding name #t i))
- (else (error "unknown binding type" name type)))))
- bindings))
- (define (push-bindings! bindings)
- (push (cons (current-address) bindings) open-bindings))
- (define (close-binding!)
- (let* ((bindings (pop open-bindings))
- (start (car bindings))
- (end (current-address)))
- (for-each
- (lambda (open)
- ;; the cons is for dsu sort
- (push (cons start
- (make-binding (btemp:name open) (btemp:extp open)
- (btemp:index open) start end))
- closed-bindings))
- (cdr bindings))))
- (define (finish-bindings!)
- (while (not (null? open-bindings)) (close-binding!))
- (set! closed-bindings
- (stable-sort! (reverse! closed-bindings)
- (lambda (x y) (< (car x) (car y)))))
- (set! closed-bindings (map cdr closed-bindings)))
- (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> vars)
- (push-bindings! (munge-bindings vars nargs)))
-
- ((<glil-mv-bind> vars rest)
- (push-bindings! (munge-bindings vars nargs))
- (push-code! `(truncate-values ,(length vars) ,(if rest 1 0))))
-
- ((<glil-unbind>)
- (close-binding!))
-
- ((<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 ,(+ nargs index)))
- (push-code! `(local-set ,(+ nargs 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-toplevel> op name)
- (case op
- ((ref set)
- (cond
- (toplevel
- (push-object! (make-vlink-now #:key name))
- (push-code! (case op
- ((ref) '(variable-ref))
- ((set) '(variable-set)))))
- (else
- (let* ((var (make-vlink-later #:key name))
- (i (object-index var)))
- (push-code! (case op
- ((ref) `(toplevel-ref ,i))
- ((set) `(toplevel-set ,i))))))))
- ((define)
- (push-object! (make-vdefine #:name name))
- (push-code! '(variable-set)))
- (else
- (error "unknown toplevel var kind" op name))))
-
- ((<glil-module> op mod name public?)
- (let ((key (list mod name public?)))
- (case op
- ((ref set)
- (cond
- (toplevel
- (push-object! (make-vlink-now #:key key))
- (push-code! (case op
- ((ref) '(variable-ref))
- ((set) '(variable-set)))))
- (else
- (let* ((var (make-vlink-later #:key key))
- (i (object-index var)))
- (push-code! (case op
- ((ref) `(toplevel-ref ,i))
- ((set) `(toplevel-set ,i))))))))
- (else
- (error "unknown module var kind" op key)))))
-
- ((<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)
- (finish-bindings!)
-; (format #t "codegen: stack = ~a~%" (reverse stack))
- (let ((bytes (stack->bytes (reverse! stack) label-alist)))
- (if toplevel
- (bytecode->objcode bytes nlocs nexts)
- (let ((metathunk (make-meta closed-bindings
- (reverse! source-alist)
- meta)))
- (make-bytespec #:nargs nargs #:nrest nrest #:nlocs nlocs
- #:nexts nexts #:bytes bytes
- #:meta metathunk
- #:objs (if (and (null? object-alist) (not metathunk))
- #f
- (list->vector
- (append object-pre-elements
- (map car (reverse! object-alist)))))
- #: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)))))))
-
-\f
-;;;
-;;; 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> nargs nrest nlocs nexts bytes meta objs closure?)
- ;; dump parameters
- (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
- (if (> (+ nargs nlocs) 255)
- (error "too many locals" nargs nlocs))
- ;; really it should be a flag..
- (if (> nrest 1) (error "nrest should be 0 or 1" nrest))
- (if (> nexts 255) (error "too many externals" nexts))
- (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> key)
- (dump! key))
- ((<vlink-now> key)
- (dump! key)
- (push-code! '(link-now)))
- ((<vdefine> name)
- (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)))))
HCoop / bpt / guile.git / blobdiff