summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/assembly.scm42
-rw-r--r--module/language/assembly/compile-bytecode.scm15
-rw-r--r--module/language/glil/Makefile.am2
-rw-r--r--module/language/glil/compile-assembly.scm4
-rw-r--r--module/language/glil/compile-objcode.scm412
-rw-r--r--module/language/glil/spec.scm8
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))
)