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

placeholder for meta and module in a program's object table

Browse source 
* module/language/glil/compile-objcode.scm (codegen): If the generated
  objcode will have a meta or it has objects, prepend two cells to the
  object table: one for the meta, and one for the module. This is a
  placeholder for future work.
This commit is contained in:
Andy Wingo 2009-01-17 15:08:05 +01:00
parent 86872cc392
commit a72317988f
1 changed files with 22 additions and 22 deletions
Download patch file Download diff file Expand all files Collapse all files

44
module/language/glil/compile-objcode.scm
View file

@ -115,7 +115,16 @@
(closed-bindings '()) (closed-bindings '())
(source-alist '()) (source-alist '())
(label-alist '()) (label-alist '())
;; the pre-elements are prepended to the object vector
;; in practice these are placeholders for module & meta.
(object-pre-elements '(#f #f))
(object-alist '())) (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) (define (push-code! code)
; (format #t "push-code! ~a~%" code) ; (format #t "push-code! ~a~%" code)
(push (code->bytes code) stack)) (push (code->bytes code) stack))
@ -124,12 +133,7 @@
(toplevel (toplevel
(dump-object! push-code! x)) (dump-object! push-code! x))
(else (else
(let ((i (cond ((object-assoc x object-alist) => cdr) (push-code! `(object-ref ,(object-index x))))))
(else
(let ((i (length object-alist)))
(set! object-alist (acons x i object-alist))
i)))))
(push-code! `(object-ref ,i))))))
(define (munge-bindings bindings nargs) (define (munge-bindings bindings nargs)
(map (map
(lambda (v) (lambda (v)
@ -217,11 +221,7 @@
((set) '(variable-set))))) ((set) '(variable-set)))))
(else (else
(let* ((var (make-vlink-later #:key name)) (let* ((var (make-vlink-later #:key name))
(i (cond ((object-assoc var object-alist) => cdr) (i (object-index var)))
(else
(let ((i (length object-alist)))
(set! object-alist (acons var i object-alist))
i)))))
(push-code! (case op (push-code! (case op
((ref) `(toplevel-ref ,i)) ((ref) `(toplevel-ref ,i))
((set) `(toplevel-set ,i)))))))) ((set) `(toplevel-set ,i))))))))
@ -243,11 +243,7 @@
((set) '(variable-set))))) ((set) '(variable-set)))))
(else (else
(let* ((var (make-vlink-later #:key key)) (let* ((var (make-vlink-later #:key key))
(i (cond ((object-assoc var object-alist) => cdr) (i (object-index var)))
(else
(let ((i (length object-alist)))
(set! object-alist (acons var i object-alist))
i)))))
(push-code! (case op (push-code! (case op
((ref) `(toplevel-ref ,i)) ((ref) `(toplevel-ref ,i))
((set) `(toplevel-set ,i)))))))) ((set) `(toplevel-set ,i))))))))
@ -282,14 +278,18 @@
(let ((bytes (stack->bytes (reverse! stack) label-alist))) (let ((bytes (stack->bytes (reverse! stack) label-alist)))
(if toplevel (if toplevel
(bytecode->objcode bytes nlocs nexts) (bytecode->objcode bytes nlocs nexts)
(let ((metathunk (make-meta closed-bindings
(reverse! source-alist)
meta)))
(make-bytespec #:nargs nargs #:nrest nrest #:nlocs nlocs (make-bytespec #:nargs nargs #:nrest nrest #:nlocs nlocs
#:nexts nexts #:bytes bytes #:nexts nexts #:bytes bytes
#:meta (make-meta closed-bindings #:meta metathunk
(reverse! source-alist) #:objs (if (and (null? object-alist) (not metathunk))
meta) #f
#:objs (let ((objs (map car (reverse! object-alist)))) (list->vector
(if (null? objs) #f (list->vector objs))) (append object-pre-elements
#:closure? (venv-closure? venv)))))))))) (map car (reverse! object-alist)))))
#:closure? (venv-closure? venv)))))))))))
(define (object-assoc x alist) (define (object-assoc x alist)
(record-case x (record-case x