diff options
Diffstat (limited to 'module/language/glil/compile-objcode.scm')
-rw-r--r-- | module/language/glil/compile-objcode.scm | 412 |
1 files changed, 412 insertions, 0 deletions
diff --git a/module/language/glil/compile-objcode.scm b/module/language/glil/compile-objcode.scm new file mode 100644 index 000000000..16f160293 --- /dev/null +++ b/module/language/glil/compile-objcode.scm @@ -0,0 +1,412 @@ +;;; 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 def) + #: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)) + + +;;; +;;; 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> 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))) +(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 #: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)))) + +;; 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-asm> vars meta) ; body? + (let ((stack '()) + (open-bindings '()) + (closed-bindings '()) + (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 (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> (binds vars)) + (push-bindings! (munge-bindings binds (glil-vars-nargs vars)))) + + ((<glil-mv-bind> (binds vars) rest) + (push-bindings! (munge-bindings binds (glil-vars-nargs vars))) + (push-code! `(truncate-values ,(length binds) ,(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 ,(+ (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-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 (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) `(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 (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) `(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 (glil-vars-nlocs vars) (glil-vars-nexts vars)) + (make-bytespec #:vars vars #:bytes bytes + #:meta (make-meta closed-bindings + (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 + (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))))) |