X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/cd9d95d760e9b7576f90510ed584b844450cdc2c..fd3585753a34fde835cd9b660fe7322e9543721b:/module/system/vm/assemble.scm diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm index 19e633b82..bbbee35cb 100644 --- a/module/system/vm/assemble.scm +++ b/module/system/vm/assemble.scm @@ -20,17 +20,17 @@ ;;; 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)) @@ -42,9 +42,10 @@ (define-record ( venv glil body)) (define-record ( parent nexts closure?)) -(define-record ( id)) -(define-record ( module name)) -(define-record ( module name)) +;; key is either a symbol or the list (MODNAME SYM PUBLIC?) +(define-record ( key)) +(define-record ( key)) +(define-record ( name)) (define-record ( vars bytes meta objs closure?)) @@ -54,10 +55,10 @@ (define (preprocess x e) (record-case x - (( vars body) - (let* ((venv (make-venv :parent e :nexts (glil-vars-nexts vars) :closure? #f)) + (( 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))) (( op depth index) (do ((d depth (- d 1)) (e e (venv-parent e))) @@ -71,9 +72,35 @@ ;;; 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 - (( venv glil body) (record-case glil (( vars) + (( venv glil body) (record-case glil (( vars meta) ; body? (let ((stack '()) (binding-alist '()) (source-alist '()) @@ -81,10 +108,11 @@ (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 @@ -93,9 +121,6 @@ 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 @@ -115,6 +140,19 @@ (set! binding-alist (acons (current-address) bindings binding-alist)))) + (( (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))))) + (() (set! binding-alist (acons (current-address) #f binding-alist))) @@ -146,23 +184,59 @@ (push-code! `(external-ref ,(+ n index))) (push-code! `(external-set ,(+ n index))))))) - (( op module name) + (( 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)))) + + (( 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))))) (( label) (set! label-alist (assq-set! label-alist label (current-address)))) (( inst label) - (set! stack (cons (list inst label) stack))) + (push (list inst label) stack)) (( inst nargs) (if (instruction? inst) @@ -173,7 +247,11 @@ (push-code! (list inst))) (else (error "Wrong number of arguments:" inst nargs)))) - (error "Unknown instruction:" inst))))) + (error "Unknown instruction:" inst))) + + (( nargs ra) + (push (list 'mv-call nargs ra) stack)))) + ;; ;; main (for-each generate-code body) @@ -181,38 +259,50 @@ (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 - (() (assoc x alist)) + (() (assoc x alist)) + (() (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))))))) ;;; @@ -235,14 +325,11 @@ (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)) @@ -255,17 +342,16 @@ ;; dump meta data (if meta (dump! meta)) ;; dump bytecode - (push-code! `(load-program ,bytes))) - (( module name) - ;; FIXME: dump module - (push-code! `(link ,(symbol->string name)))) - (( module name) - ;; FIXME: dump module + (push-code! `(load-program ,bytes))) + (( key) + (dump! key)) + (( key) + (dump! key) + (push-code! '(link-now))) + (( name) (push-code! `(define ,(symbol->string name)))) - (( 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))) @@ -279,8 +365,7 @@ ((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)))