mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-17 17:20:29 +02:00
Code Activity

begin-program takes properties alist

Browse source 
* module/system/vm/assembler.scm (assert-match): New helper macro to
  check argument types.
  (<meta>): Add properties field.  Rename name field to "label" to
  indicate that it should be unique.
  (make-meta, meta-name): New helpers.
  (begin-program): Take additional properties argument.
  (emit-init-constants): Adapt to begin-program change.
  (link-symtab): Allow for anonymous procedures.

* test-suite/tests/rtl.test: Adapt tests.
This commit is contained in:
Andy Wingo 2013-05-14 10:25:38 +02:00
parent 82e299f386
commit 2a4daafd30
2 changed files with 60 additions and 27 deletions
Download patch file Download diff file Expand all files Collapse all files

29
module/system/vm/assembler.scm
View file

@ -110,13 +110,27 @@
;;; A <meta> entry collects metadata for one procedure. Procedures are
;;; written as contiguous ranges of RTL code.
;;;
(define-syntax-rule (assert-match arg pattern kind)
(let ((x arg))
(unless (match x (pattern #t) (_ #f))
(error (string-append "expected " kind) x))))
(define-record-type <meta>
(make-meta name low-pc high-pc)
(%make-meta label properties low-pc high-pc)
meta?
(name meta-name)
(label meta-label)
(properties meta-properties set-meta-properties!)
(low-pc meta-low-pc)
(high-pc meta-high-pc set-meta-high-pc!))
(define (make-meta label properties low-pc)
(assert-match label (? symbol?) "symbol")
(assert-match properties (((? symbol?) . _) ...) "alist with symbolic keys")
(%make-meta label properties low-pc #f))
(define (meta-name meta)
(assq-ref (meta-properties meta) 'name))
(define-syntax *block-size* (identifier-syntax 32))
;;; An assembler collects all of the words emitted during assembly, and
@ -597,13 +611,14 @@ returned instead."
(let ((loc (intern-constant asm (make-static-procedure label))))
(emit-make-non-immediate asm dst loc)))
(define-macro-assembler (begin-program asm label)
(define-macro-assembler (begin-program asm label properties)
(emit-label asm label)
(let ((meta (make-meta label (asm-start asm) #f)))
(let ((meta (make-meta label properties (asm-start asm))))
(set-asm-meta! asm (cons meta (asm-meta asm)))))
(define-macro-assembler (end-program asm)
(set-meta-high-pc! (car (asm-meta asm)) (asm-start asm)))
(let ((meta (car (asm-meta asm))))
(set-meta-high-pc! meta (asm-start asm))))
(define-macro-assembler (label asm sym)
(set-asm-labels! asm (acons sym (asm-start asm) (asm-labels asm))))
@ -686,7 +701,7 @@ a procedure to do that and return its label. Otherwise return
(and (not (null? inits))
(let ((label (gensym "init-constants")))
(emit-text asm
`((begin-program ,label)
`((begin-program ,label ())
(assert-nargs-ee/locals 0 1)
,@(reverse inits)
(load-constant 0 ,*unspecified*)
@ -1025,7 +1040,7 @@ it will be added to the GC roots at runtime."
(strtab (make-string-table))
(bv (make-bytevector (* n size) 0)))
(define (intern-string! name)
(string-table-intern! strtab (symbol->string name)))
(string-table-intern! strtab (if name (symbol->string name) "")))
(for-each
(lambda (meta n)
(let ((name (intern-string! (meta-name meta))))