diff options
author | Andy Wingo <wingo@pobox.com> | 2009-01-30 11:02:01 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-01-30 11:02:01 +0100 |
commit | 4b3184828416acfa5c099a54954ca00ce3cc0d0d (patch) | |
tree | 937907a27c514e9a3fb0c5c009a500a44d7ccfd0 | |
parent | 6f78702819e355180a71de6902766cdecfa84755 (diff) | |
download | guile-4b3184828416acfa5c099a54954ca00ce3cc0d0d.tar.gz |
remove glil->objcode path in favor of passing through assembly; refactorings.
* module/language/assembly.scm: Refactor a bit; remove the name "code"
from the API, as it's too generic, and replace with "assembly".
* module/language/assembly/compile-bytecode.scm: Get byte lengths via,
well, byte-length.
* module/language/glil/Makefile.am:
* module/language/glil/spec.scm:
* module/language/glil/compile-objcode.scm: Remove compile-objcode, as we
just go through bytecode now.
* module/language/glil/compile-assembly.scm (glil->assembly)
(dump-object): s/object->code/object->assembly/.
-rw-r--r-- | module/language/assembly.scm | 42 | ||||
-rw-r--r-- | module/language/assembly/compile-bytecode.scm | 15 | ||||
-rw-r--r-- | module/language/glil/Makefile.am | 2 | ||||
-rw-r--r-- | module/language/glil/compile-assembly.scm | 4 | ||||
-rw-r--r-- | module/language/glil/compile-objcode.scm | 412 | ||||
-rw-r--r-- | module/language/glil/spec.scm | 8 |
6 files changed, 34 insertions, 449 deletions
diff --git a/module/language/assembly.scm b/module/language/assembly.scm index e66e753e2..b124081a7 100644 --- a/module/language/assembly.scm +++ b/module/language/assembly.scm @@ -22,33 +22,37 @@ (define-module (language assembly) #:use-module (system base pmatch) #:use-module (system vm instruction) - #:export (byte-length code-pack code-unpack object->code code->object)) + #:export (byte-length + assembly-pack assembly-unpack + object->assembly assembly->object)) -(define (len+ len) - (+ 3 len)) +;; nargs, nrest, nlocs, nexts, len +(define *program-header-len* (+ 1 1 1 1 4)) -(define (byte-length x) - (pmatch x +;; lengths are encoded in 3 bytes +(define *len-len* 3) + +(define (byte-length assembly) + (pmatch assembly (,label (guard (not (pair? label))) 0) ((load-integer ,str) - (1+ (len+ (string-length str)))) + (+ 1 *len-len* (string-length str))) ((load-number ,str) - (1+ (len+ (string-length str)))) + (+ 1 *len-len* (string-length str))) ((load-string ,str) - (1+ (len+ (string-length str)))) + (+ 1 *len-len* (string-length str))) ((load-symbol ,str) - (1+ (len+ (string-length str)))) + (+ 1 *len-len* (string-length str))) ((load-keyword ,str) - (1+ (len+ (string-length str)))) + (+ 1 *len-len* (string-length str))) ((define ,str) - (1+ (len+ (string-length str)))) + (+ 1 *len-len* (string-length str))) ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len . ,code) - ;; lengths of nargs, nrest, nlocs, nexts, len, and code, respectively - (1+ (+ 1 1 1 1 4 len))) + (+ 1 *program-header-len* len)) ((,inst . _) (guard (>= (instruction-length inst) 0)) - (1+ (instruction-length inst))) - (else (error "unknown instruction" x)))) + (+ 1 (instruction-length inst))) + (else (error "unknown instruction" assembly)))) ;;; ;;; Code compress/decompression @@ -61,11 +65,11 @@ (define *expansions* (map (lambda (x) (cons (cdr x) (car x))) *abbreviations*)) -(define (code-pack code) +(define (assembly-pack code) (or (assoc-ref code *abbreviations*) code)) -(define (code-unpack code) +(define (assembly-unpack code) (or (assoc-ref code *expansions*) code)) @@ -74,7 +78,7 @@ ;;; Encoder/decoder ;;; -(define (object->code x) +(define (object->assembly x) (cond ((eq? x #t) `(make-true)) ((eq? x #f) `(make-false)) ((null? x) `(make-eol)) @@ -88,7 +92,7 @@ ((char? x) `(make-char8 ,(char->integer x))) (else #f))) -(define (code->object code) +(define (assembly->object code) (pmatch code ((make-true) #t) ((make-false) #f) ;; FIXME: Same as the `else' case! diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm index e0d0af923..17a71f21b 100644 --- a/module/language/assembly/compile-bytecode.scm +++ b/module/language/assembly/compile-bytecode.scm @@ -21,27 +21,26 @@ (define-module (language assembly compile-bytecode) #:use-module (system base pmatch) + #:use-module (language assembly) #:use-module (system vm instruction) #:use-module (srfi srfi-4) #:use-module ((srfi srfi-1) #:select (fold)) #:export (compile-bytecode write-bytecode)) -(define *program-header-len* 8) - (define (compile-bytecode assembly env . opts) (pmatch assembly - ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len . ,code) - (letrec ((v (make-u8vector (+ *program-header-len* len))) + ((load-program . _) + ;; the 1- and -1 are so that we drop the load-program byte + (letrec ((v (make-u8vector (1- (byte-length assembly)))) (i -1) (write-byte (lambda (b) - ;; drop the load-program byte (if (>= i 0) (u8vector-set! v i b)) (set! i (1+ i)))) (get-addr (lambda () i))) (write-bytecode assembly write-byte get-addr '()) - (if (not (= i (u8vector-length v))) - (error "incorrect length in assembly" i len)) - (values v env))) + (if (= i (u8vector-length v)) + (values v env) + (error "incorrect length in assembly" i (u8vector-length v))))) (else (error "bad assembly" assembly)))) (define (write-bytecode asm write-byte get-addr labels) diff --git a/module/language/glil/Makefile.am b/module/language/glil/Makefile.am index a078cdf0c..d3f5e8d61 100644 --- a/module/language/glil/Makefile.am +++ b/module/language/glil/Makefile.am @@ -1,3 +1,3 @@ -SOURCES = spec.scm compile-objcode.scm compile-assembly.scm +SOURCES = spec.scm compile-assembly.scm modpath = language/glil include $(top_srcdir)/am/guilec diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm index a2e51d507..55699300f 100644 --- a/module/language/glil/compile-assembly.scm +++ b/module/language/glil/compile-assembly.scm @@ -210,7 +210,7 @@ ((<glil-const> obj) (cond - ((object->code obj) + ((object->assembly obj) => (lambda (code) (emit-code (list code)))) ((not object-alist) @@ -318,7 +318,7 @@ (let dump ((x x)) (cond - ((object->code x) => list) + ((object->assembly x) => list) ((variable-cache-cell? x) (dump (variable-cache-cell-key x))) ((subprogram? x) (subprogram-code x)) ((and (integer? x) (exact? x)) diff --git a/module/language/glil/compile-objcode.scm b/module/language/glil/compile-objcode.scm deleted file mode 100644 index 8cef763d3..000000000 --- a/module/language/glil/compile-objcode.scm +++ /dev/null @@ -1,412 +0,0 @@ -;;; 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)) - - -;;; -;;; 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?) - - -;;; -;;; 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))) - - -;;; -;;; 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))))))) - - -;;; -;;; 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))))) diff --git a/module/language/glil/spec.scm b/module/language/glil/spec.scm index deb76ee81..5cd81b712 100644 --- a/module/language/glil/spec.scm +++ b/module/language/glil/spec.scm @@ -21,19 +21,14 @@ (define-module (language glil spec) #:use-module (system base language) - #:use-module (language objcode spec) #:use-module (language assembly spec) #:use-module (language glil) - #:use-module (language glil compile-objcode) #:use-module (language glil compile-assembly) #:export (glil)) (define (write-glil exp . port) (apply write (unparse-glil exp) port)) -(define (compile x e opts) - (values (compile-objcode x e) e)) - (define (compile-asm x e opts) (values (compile-assembly x) e)) @@ -43,6 +38,5 @@ #:reader read #:printer write-glil #:parser parse-glil - #:compilers `((,assembly . ,compile-asm) - (,objcode . ,compile)) + #:compilers `((,assembly . ,compile-asm)) ) |