;;; Code:
(define-module (system vm assemble)
- :use-syntax (system base syntax)
- :use-module (system il glil)
- :use-module ((system vm core)
- :select (instruction? instruction-pops
- make-binding
- bytecode->objcode))
- :use-module (system vm conv)
- :use-module (ice-9 regex)
- :use-module (ice-9 common-list)
- :use-module (srfi srfi-4)
- :export (preprocess codegen 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))
(define-record (<vm-asm> venv glil body))
(define-record (<venv> parent nexts closure?))
-(define-record (<vmod> id))
-(define-record (<vlink> module name))
-(define-record (<vdefine> module name))
+;; 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?))
\f
(define (preprocess x e)
(record-case x
- ((<glil-asm> vars body)
- (let* ((venv (make-venv :parent e :nexts (glil-vars-nexts vars) :closure? #f))
+ ((<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)))
+ (make-vm-asm #:venv venv #:glil x #:body body)))
((<glil-external> op depth index)
(do ((d depth (- d 1))
(e e (venv-parent e)))
;;; 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)
+ ((<vm-asm> venv glil body) (record-case glil ((<glil-asm> vars meta) ; body?
(let ((stack '())
(binding-alist '())
(source-alist '())
(object-alist '()))
(define (push-code! code)
; (format #t "push-code! ~a~%" code)
- (set! stack (cons (code->bytes code) stack)))
+ (push (code->bytes code) stack))
(define (push-object! x)
(cond ((object->code x) => push-code!)
- (toplevel (dump-object! push-code! x))
+ (toplevel
+ (dump-object! push-code! x))
(else
(let ((i (cond ((object-assoc x object-alist) => cdr)
(else
i)))))
(push-code! `(object-ref ,i))))))
(define (current-address)
- (define (byte-length x)
- (cond ((u8vector? x) (u8vector-length x))
- (else 3)))
(apply + (map byte-length stack)))
(define (generate-code x)
(record-case x
(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)))
(push-code! `(external-ref ,(+ n index)))
(push-code! `(external-set ,(+ n index)))))))
- ((<glil-module> op module name)
+ ((<glil-toplevel> op name)
(case op
- ((ref)
- (push-object! (make-vlink :module module :name name))
- (push-code! '(variable-ref)))
- ((set)
- (push-object! (make-vlink :module module :name name))
- (push-code! '(variable-set)))
+ ((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) `(late-variable-ref ,i))
+ ((set) `(late-variable-set ,i))))))))
((define)
- (push-object! (make-vdefine :module module :name name))
- (push-code! '(variable-set)))))
+ (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) `(late-variable-ref ,i))
+ ((set) `(late-variable-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)
- (set! stack (cons (list inst label) stack)))
+ (push (list inst label) stack))
((<glil-call> inst nargs)
(if (instruction? inst)
(push-code! (list inst)))
(else
(error "Wrong number of arguments:" inst nargs))))
- (error "Unknown instruction:" inst)))))
+ (error "Unknown instruction:" inst)))
+
+ ((<glil-mv-call> nargs ra)
+ (push (list 'mv-call nargs ra) stack))))
+
;;
;; main
(for-each generate-code body)
(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 (if (and (null? binding-alist)
- (null? source-alist))
- #f
- (cons (reverse! binding-alist)
- (reverse! source-alist)))
- :objs (let ((objs (map car (reverse! object-alist))))
+ (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))))))))))
+ #:closure? (venv-closure? venv))))))))))
(define (object-assoc x alist)
(record-case x
- ((<vlink>) (assoc x alist))
+ ((<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)
- (apply u8vector
- (apply append
- (map u8vector->list (reverse! result))))
- (let ((bytes (car stack)))
- (if (pair? bytes)
- (let* ((offset (- (assq-ref label-alist (cadr bytes))
- (+ addr 3)))
- (n (if (< offset 0) (+ offset 65536) offset)))
- (set! bytes (code->bytes (list (car bytes)
- (quotient n 256)
- (modulo n 256))))))
- (loop (cons bytes result)
- (cdr stack)
- (+ addr (u8vector-length bytes)))))))
+ (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
;;;
(let ((nargs (glil-vars-nargs vars)) (nrest (glil-vars-nrest vars))
(nlocs (glil-vars-nlocs vars)) (nexts (glil-vars-nexts vars)))
(cond
- ((and (< nargs 4) (< nlocs 8) (< nexts 4))
- ;; 8-bit representation
- (let ((x (+ (* nargs 64) (* nrest 32) (* nlocs 4) nexts)))
- (push-code! `(make-int8 ,x))))
((and (< nargs 16) (< nlocs 128) (< nexts 16))
;; 16-bit representation
- (let ((x (+ (* nargs 4096) (* nrest 2048) (* nlocs 16) nexts)))
- (push-code! `(make-int16 ,(quotient x 256) ,(modulo x 256)))))
+ (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))
;; dump meta data
(if meta (dump! meta))
;; dump bytecode
- (push-code! `(load-program ,bytes)))
- ((<vlink> module name)
- ;; FIXME: dump module
- (push-code! `(link ,(symbol->string name))))
- ((<vdefine> module name)
- ;; FIXME: dump module
+ (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))))
- ((<vmod> id)
- (push-code! `(load-module ,id)))
(else
- (error "assemble: unknown record type"))))
+ (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)))
((symbol? x)
(push-code! `(load-symbol ,(symbol->string x))))
((keyword? x)
- (push-code! `(load-keyword
- ,(symbol->string (keyword-dash-symbol x)))))
+ (push-code! `(load-keyword ,(symbol->string (keyword->symbol x)))))
((list? x)
(for-each dump! x)
(let ((len (length x)))
HCoop / bpt / guile.git / blobdiff