mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 19:50:24 +02:00
Code Activity

*** empty log message ***

Browse source
This commit is contained in:
Keisuke Nishida 2001-04-09 01:28:16 +00:00
parent 4c9ad01d44
commit f0c9993564
1 changed files with 26 additions and 23 deletions
Download patch file Download diff file Expand all files Collapse all files

49
module/system/vm/assemble.scm
View file

@ -76,11 +76,16 @@
(define (push-code! code) (define (push-code! code)
(set! stack (optimizing-push code stack))) (set! stack (optimizing-push code stack)))
(define (push-object! x) (define (push-object! x)
(let ((index (or ((if (vlink? x) assoc-ref assq-ref) object-alist x) (cond (toplevel (dump-object! push-code! x))
(let ((index (length object-alist))) ((object->code x) => push-code!)
(set! object-alist (acons x index object-alist)) (else
index)))) (let ((index (or (if (vlink? x)
(push-code! `(object-ref ,index)))) (assoc-ref object-alist x)
(assq-ref object-alist x))
(let ((i (length object-alist)))
(set! object-alist (acons x i object-alist))
i))))
(push-code! `(object-ref ,index))))))
(define (label-ref key) (define (label-ref key)
(assq-ref label-alist key)) (assq-ref label-alist key))
(define (label-set key) (define (label-set key)
@ -89,41 +94,39 @@
(define (generate-code x) (define (generate-code x)
(match x (match x
(($ <vm-asm> venv) (($ <vm-asm> venv)
(let ((spec (codegen x #f))) (push-object! (codegen x #f))
(if toplevel
(dump-object! spec push-code!)
(push-object! spec)))
(if (venv-closure? venv) (push-code! `(make-closure)))) (if (venv-closure? venv) (push-code! `(make-closure))))
(($ <glil-void>) (($ <glil-void>)
(push-code! `(void))) (push-code! `(void)))
(($ <glil-const> x) (($ <glil-const> x)
(if toplevel (push-object! x))
(dump-object! x push-code!)
(cond ((object->code x) => push-code!)
(else (push-object! x)))))
(($ <glil-argument> op index) (($ <glil-argument> op index)
(push-code! `(,(symbol-append 'local- op) ,index))) (if (eq? op 'ref)
(push-code! `(local-ref ,index)))
(push-code! `(local-set ,index)))
(($ <glil-local> op index) (($ <glil-local> op index)
(push-code! `(,(symbol-append 'local- op) ,(+ nargs index)))) (if (eq? op 'ref)
(push-code! `(local-ref ,(+ nargs index)))
(push-code! `(local-set ,(+ nargs index)))))
(($ <glil-external> op depth index) (($ <glil-external> op depth index)
(do ((e venv (venv-parent e)) (do ((e venv (venv-parent e))
(d depth (1- d)) (d depth (1- d))
(n 0 (+ n (venv-nexts e)))) (n 0 (+ n (venv-nexts e))))
((= d 0) ((= d 0)
(push-code! `(,(symbol-append 'external- op) ,(+ n index)))))) (if (eq? op 'ref)
(push-code! `(external-ref ,(+ n index)))
(push-code! `(external-set ,(+ n index)))))))
(($ <glil-module> op module name) (($ <glil-module> op module name)
;; (let ((vlink (make-vlink (make-vmod module) name))) (push-object! (make-vlink #f name)) ;; FIXME: (make-vmod module)
(let ((vlink (make-vlink #f name))) (if (eq? op 'ref)
(if toplevel (push-code! '(variable-ref))
(dump-object! vlink push-code!) (push-code! '(variable-set))))
(push-object! vlink)))
(push-code! (list (symbol-append 'variable- op))))
(($ <glil-label> label) (($ <glil-label> label)
(label-set label)) (label-set label))
@ -200,7 +203,7 @@
;; NOTE: undumpped in vm_load.c. ;; NOTE: undumpped in vm_load.c.
(define (dump-object! x push-code!) (define (dump-object! push-code! x)
(let dump! ((x x)) (let dump! ((x x))
(cond (cond
((object->code x) => push-code!) ((object->code x) => push-code!)