make-binding
bytecode->objcode))
:use-module (system vm conv)
- :use-module (ice-9 match)
:use-module (ice-9 regex)
:use-module (ice-9 common-list)
:use-module (srfi srfi-4)
(define-record (<venv> parent nexts closure?))
(define-record (<vmod> id))
(define-record (<vlink> module name))
+(define-record (<vlate-bound> name))
+(define-record (<vdefine> module name))
(define-record (<bytespec> vars bytes meta objs closure?))
\f
;;;
(define (preprocess x e)
- (match x
- (($ <glil-asm> vars body)
- (let* ((venv (<venv> :parent e :nexts (slot vars 'nexts) :closure? #f))
+ (record-case x
+ ((<glil-asm> vars body)
+ (let* ((venv (make-venv :parent e :nexts (glil-vars-nexts vars) :closure? #f))
(body (map (lambda (x) (preprocess x venv)) body)))
- (<vm-asm> :venv venv :glil x :body body)))
- (($ <glil-external> op depth index)
+ (make-vm-asm :venv venv :glil x :body body)))
+ ((<glil-external> op depth index)
(do ((d depth (- d 1))
- (e e (slot e 'parent)))
+ (e e (venv-parent e)))
((= d 0))
- (set! (slot e 'closure?) #t))
+ (set! (venv-closure? e) #t))
x)
(else x)))
;;;
(define (codegen glil toplevel)
- (match glil
- (($ <vm-asm> venv ($ <glil-asm> vars _) body)
+ (record-case glil
+ ((<vm-asm> venv glil body) (record-case glil ((<glil-asm> vars)
(let ((stack '())
(binding-alist '())
(source-alist '())
(else 3)))
(apply + (map byte-length stack)))
(define (generate-code x)
- (match x
- (($ <vm-asm> venv)
+ (record-case x
+ ((<vm-asm> venv)
(push-object! (codegen x #f))
- (if (slot venv 'closure?) (push-code! `(make-closure))))
+ (if (venv-closure? venv) (push-code! `(make-closure))))
- (($ <glil-bind> binds)
+ ((<glil-bind> (binds vars))
(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 (+ vars.nargs 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))))
- (($ <glil-unbind>)
+ ((<glil-unbind>)
(set! binding-alist (acons (current-address) #f binding-alist)))
- (($ <glil-source> loc)
+ ((<glil-source> loc)
(set! source-alist (acons (current-address) loc source-alist)))
- (($ <glil-void>)
+ ((<glil-void>)
(push-code! '(void)))
- (($ <glil-const> x)
- (push-object! x))
+ ((<glil-const> obj)
+ (push-object! obj))
- (($ <glil-argument> op index)
+ ((<glil-argument> op index)
(if (eq? op 'ref)
(push-code! `(local-ref ,index))
(push-code! `(local-set ,index))))
- (($ <glil-local> op index)
+ ((<glil-local> op index)
(if (eq? op 'ref)
- (push-code! `(local-ref ,(+ vars.nargs index)))
- (push-code! `(local-set ,(+ vars.nargs index)))))
+ (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 e.parent)
+ ((<glil-external> op depth index)
+ (do ((e venv (venv-parent e))
(d depth (1- d))
- (n 0 (+ n e.nexts)))
+ (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-module> op module name)
- (push-object! (<vlink> :module #f :name name))
- (if (eq? op 'ref)
- (push-code! '(variable-ref))
- (push-code! '(variable-set))))
+ ((<glil-module> op module 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)))
+ ((define)
+ (push-object! (make-vdefine :module module :name name))
+ (push-code! '(variable-set)))))
+
+ ((<glil-late-bound> op name)
+ (let* ((var (make-vlate-bound :name name))
+ (i (cond ((object-assoc var object-alist) => cdr)
+ (else
+ (let ((i (length object-alist)))
+ (set! object-alist (acons var i object-alist))
+ i)))))
+ (case op
+ ((ref)
+ (push-code! `(late-variable-ref ,i)))
+ ((set)
+ (push-code! `(late-variable-set ,i)))
+ (else (error "unknown late bound" op name)))))
- (($ <glil-label> label)
+ ((<glil-label> label)
(set! label-alist (assq-set! label-alist label (current-address))))
- (($ <glil-branch> inst label)
+ ((<glil-branch> inst label)
(set! stack (cons (list inst label) stack)))
- (($ <glil-call> inst nargs)
+ ((<glil-call> inst nargs)
(if (instruction? inst)
(let ((pops (instruction-pops inst)))
(cond ((< pops 0)
; (format #t "codegen: stack = ~a~%" (reverse stack))
(let ((bytes (stack->bytes (reverse! stack) label-alist)))
(if toplevel
- (bytecode->objcode bytes vars.nlocs vars.nexts)
- (<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))))
- (if (null? objs) #f (list->vector objs)))
- :closure? venv.closure?)))))))
+ (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))))
+ (if (null? objs) #f (list->vector objs)))
+ :closure? (venv-closure? venv))))))))))
(define (object-assoc x alist)
- (match x
- (($ <vlink>) (assoc x alist))
+ (record-case x
+ ((<vlink>) (assoc x alist))
(else (assq x alist))))
(define (stack->bytes stack label-alist)
(let dump! ((x x))
(cond
((object->code x) => push-code!)
- (else
- (match x
- (($ <bytespec> vars bytes meta objs closure?)
+ ((record? x)
+ (record-case x
+ ((<bytespec> vars bytes meta objs closure?)
;; dump parameters
- (let ((nargs vars.nargs) (nrest vars.nrest)
- (nlocs vars.nlocs) (nexts vars.nexts))
+ (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
(if meta (dump! meta))
;; dump bytecode
(push-code! `(load-program ,bytes)))
- (($ <vlink> module name)
+ ((<vlink> module name)
+ (dump! (and=> module module-name))
+ (dump! name)
+ (push-code! '(link)))
+ ((<vdefine> module name)
;; FIXME: dump module
- (push-code! `(link ,(symbol->string name))))
- (($ <vmod> id)
+ (push-code! `(define ,(symbol->string name))))
+ ((<vlate-bound> name)
+ (push-code! `(late-bind ,(symbol->string name))))
+ ((<vmod> id)
(push-code! `(load-module ,id)))
- ((and ($ integer) ($ exact))
- (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)
- (push-code! `(load-number ,(number->string x))))
- (($ string)
- (push-code! `(load-string ,x)))
- (($ symbol)
- (push-code! `(load-symbol ,(symbol->string x))))
- (($ keyword)
- (push-code! `(load-keyword
- ,(symbol->string (keyword-dash-symbol x)))))
- (($ list)
- (for-each dump! x)
- (let ((len (length x)))
- (if (>= len 65536) (too-long 'list))
- (push-code! `(list ,(quotient len 256) ,(modulo len 256)))))
- (($ pair)
- (dump! (car x))
- (dump! (cdr x))
- (push-code! `(cons)))
- (($ vector)
- (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)))))))
+ (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)))))
HCoop / bpt / guile.git / blobdiff