mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 21:40:33 +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 ;;; A <meta> entry collects metadata for one procedure. Procedures are
;;; written as contiguous ranges of RTL code. ;;; 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> (define-record-type <meta>
(make-meta name low-pc high-pc) (%make-meta label properties low-pc high-pc)
meta? meta?
(name meta-name) (label meta-label)
(properties meta-properties set-meta-properties!)
(low-pc meta-low-pc) (low-pc meta-low-pc)
(high-pc meta-high-pc set-meta-high-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)) (define-syntax *block-size* (identifier-syntax 32))
;;; An assembler collects all of the words emitted during assembly, and ;;; 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)))) (let ((loc (intern-constant asm (make-static-procedure label))))
(emit-make-non-immediate asm dst loc))) (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) (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))))) (set-asm-meta! asm (cons meta (asm-meta asm)))))
(define-macro-assembler (end-program 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) (define-macro-assembler (label asm sym)
(set-asm-labels! asm (acons sym (asm-start asm) (asm-labels asm)))) (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)) (and (not (null? inits))
(let ((label (gensym "init-constants"))) (let ((label (gensym "init-constants")))
(emit-text asm (emit-text asm
`((begin-program ,label) `((begin-program ,label ())
(assert-nargs-ee/locals 0 1) (assert-nargs-ee/locals 0 1)
,@(reverse inits) ,@(reverse inits)
(load-constant 0 ,*unspecified*) (load-constant 0 ,*unspecified*)
@ -1025,7 +1040,7 @@ it will be added to the GC roots at runtime."
(strtab (make-string-table)) (strtab (make-string-table))
(bv (make-bytevector (* n size) 0))) (bv (make-bytevector (* n size) 0)))
(define (intern-string! name) (define (intern-string! name)
(string-table-intern! strtab (symbol->string name))) (string-table-intern! strtab (if name (symbol->string name) "")))
(for-each (for-each
(lambda (meta n) (lambda (meta n)
(let ((name (intern-string! (meta-name meta)))) (let ((name (intern-string! (meta-name meta))))

58
test-suite/tests/rtl.test
View file

@ -27,7 +27,8 @@
(pass-if (object->string x) (equal? expr x)))) (pass-if (object->string x) (equal? expr x))))
(define (return-constant val) (define (return-constant val)
(assemble-program `((begin-program foo) (assemble-program `((begin-program foo
((name . foo)))
(assert-nargs-ee/locals 0 1) (assert-nargs-ee/locals 0 1)
(load-constant 0 ,val) (load-constant 0 ,val)
(return 0) (return 0)
@ -63,12 +64,14 @@
(with-test-prefix "static procedure" (with-test-prefix "static procedure"
(assert-equal 42 (assert-equal 42
(((assemble-program `((begin-program foo) (((assemble-program `((begin-program foo
((name . foo)))
(assert-nargs-ee/locals 0 1) (assert-nargs-ee/locals 0 1)
(load-static-procedure 0 bar) (load-static-procedure 0 bar)
(return 0) (return 0)
(end-program) (end-program)
(begin-program bar) (begin-program bar
((name . bar)))
(assert-nargs-ee/locals 0 1) (assert-nargs-ee/locals 0 1)
(load-constant 0 42) (load-constant 0 42)
(return 0) (return 0)
@ -81,7 +84,8 @@
;; 0: limit ;; 0: limit
;; 1: n ;; 1: n
;; 2: accum ;; 2: accum
'((begin-program countdown) '((begin-program countdown
((name . countdown)))
(assert-nargs-ee/locals 1 2) (assert-nargs-ee/locals 1 2)
(br fix-body) (br fix-body)
(label loop-head) (label loop-head)
@ -105,14 +109,16 @@
;; 0: elt ;; 0: elt
;; 1: tail ;; 1: tail
;; 2: head ;; 2: head
'((begin-program make-accum) '((begin-program make-accum
((name . make-accum)))
(assert-nargs-ee/locals 0 2) (assert-nargs-ee/locals 0 2)
(load-constant 0 0) (load-constant 0 0)
(box 0 0) (box 0 0)
(make-closure 1 accum (0)) (make-closure 1 accum (0))
(return 1) (return 1)
(end-program) (end-program)
(begin-program accum) (begin-program accum
((name . accum)))
(assert-nargs-ee/locals 1 2) (assert-nargs-ee/locals 1 2)
(free-ref 1 0) (free-ref 1 0)
(box-ref 2 1) (box-ref 2 1)
@ -129,7 +135,8 @@
(assert-equal 42 (assert-equal 42
(let ((call ;; (lambda (x) (x)) (let ((call ;; (lambda (x) (x))
(assemble-program (assemble-program
'((begin-program call) '((begin-program call
((name . call)))
(assert-nargs-ee/locals 1 0) (assert-nargs-ee/locals 1 0)
(call 1 0 ()) (call 1 0 ())
(return 1) ;; MVRA from call (return 1) ;; MVRA from call
@ -140,7 +147,8 @@
(assert-equal 6 (assert-equal 6
(let ((call-with-3 ;; (lambda (x) (x 3)) (let ((call-with-3 ;; (lambda (x) (x 3))
(assemble-program (assemble-program
'((begin-program call-with-3) '((begin-program call-with-3
((name . call-with-3)))
(assert-nargs-ee/locals 1 1) (assert-nargs-ee/locals 1 1)
(load-constant 1 3) (load-constant 1 3)
(call 2 0 (1)) (call 2 0 (1))
@ -153,7 +161,8 @@
(assert-equal 3 (assert-equal 3
(let ((call ;; (lambda (x) (x)) (let ((call ;; (lambda (x) (x))
(assemble-program (assemble-program
'((begin-program call) '((begin-program call
((name . call)))
(assert-nargs-ee/locals 1 0) (assert-nargs-ee/locals 1 0)
(tail-call 0 0) (tail-call 0 0)
(end-program))))) (end-program)))))
@ -162,7 +171,8 @@
(assert-equal 6 (assert-equal 6
(let ((call-with-3 ;; (lambda (x) (x 3)) (let ((call-with-3 ;; (lambda (x) (x 3))
(assemble-program (assemble-program
'((begin-program call-with-3) '((begin-program call-with-3
((name . call-with-3)))
(assert-nargs-ee/locals 1 1) (assert-nargs-ee/locals 1 1)
(mov 1 0) ;; R1 <- R0 (mov 1 0) ;; R1 <- R0
(load-constant 0 3) ;; R0 <- 3 (load-constant 0 3) ;; R0 <- 3
@ -174,14 +184,16 @@
(assert-equal 5.0 (assert-equal 5.0
(let ((get-sqrt-trampoline (let ((get-sqrt-trampoline
(assemble-program (assemble-program
'((begin-program get-sqrt-trampoline) '((begin-program get-sqrt-trampoline
((name . get-sqrt-trampoline)))
(assert-nargs-ee/locals 0 1) (assert-nargs-ee/locals 0 1)
(cache-current-module! 0 sqrt-scope) (cache-current-module! 0 sqrt-scope)
(load-static-procedure 0 sqrt-trampoline) (load-static-procedure 0 sqrt-trampoline)
(return 0) (return 0)
(end-program) (end-program)
(begin-program sqrt-trampoline) (begin-program sqrt-trampoline
((name . sqrt-trampoline)))
(assert-nargs-ee/locals 1 1) (assert-nargs-ee/locals 1 1)
(cached-toplevel-ref 1 sqrt-scope sqrt) (cached-toplevel-ref 1 sqrt-scope sqrt)
(tail-call 1 1) (tail-call 1 1)
@ -195,14 +207,16 @@
(assert-equal (1+ prev) (assert-equal (1+ prev)
(let ((make-top-incrementor (let ((make-top-incrementor
(assemble-program (assemble-program
'((begin-program make-top-incrementor) '((begin-program make-top-incrementor
((name . make-top-incrementor)))
(assert-nargs-ee/locals 0 1) (assert-nargs-ee/locals 0 1)
(cache-current-module! 0 top-incrementor) (cache-current-module! 0 top-incrementor)
(load-static-procedure 0 top-incrementor) (load-static-procedure 0 top-incrementor)
(return 0) (return 0)
(end-program) (end-program)
(begin-program top-incrementor) (begin-program top-incrementor
((name . top-incrementor)))
(assert-nargs-ee/locals 0 1) (assert-nargs-ee/locals 0 1)
(cached-toplevel-ref 0 top-incrementor *top-val*) (cached-toplevel-ref 0 top-incrementor *top-val*)
(add1 0 0) (add1 0 0)
@ -216,13 +230,15 @@
(assert-equal 5.0 (assert-equal 5.0
(let ((get-sqrt-trampoline (let ((get-sqrt-trampoline
(assemble-program (assemble-program
'((begin-program get-sqrt-trampoline) '((begin-program get-sqrt-trampoline
((name . get-sqrt-trampoline)))
(assert-nargs-ee/locals 0 1) (assert-nargs-ee/locals 0 1)
(load-static-procedure 0 sqrt-trampoline) (load-static-procedure 0 sqrt-trampoline)
(return 0) (return 0)
(end-program) (end-program)
(begin-program sqrt-trampoline) (begin-program sqrt-trampoline
((name . sqrt-trampoline)))
(assert-nargs-ee/locals 1 1) (assert-nargs-ee/locals 1 1)
(cached-module-ref 1 (guile) #t sqrt) (cached-module-ref 1 (guile) #t sqrt)
(tail-call 1 1) (tail-call 1 1)
@ -234,13 +250,15 @@
(assert-equal (1+ prev) (assert-equal (1+ prev)
(let ((make-top-incrementor (let ((make-top-incrementor
(assemble-program (assemble-program
'((begin-program make-top-incrementor) '((begin-program make-top-incrementor
((name . make-top-incrementor)))
(assert-nargs-ee/locals 0 1) (assert-nargs-ee/locals 0 1)
(load-static-procedure 0 top-incrementor) (load-static-procedure 0 top-incrementor)
(return 0) (return 0)
(end-program) (end-program)
(begin-program top-incrementor) (begin-program top-incrementor
((name . top-incrementor)))
(assert-nargs-ee/locals 0 1) (assert-nargs-ee/locals 0 1)
(cached-module-ref 0 (tests rtl) #f *top-val*) (cached-module-ref 0 (tests rtl) #f *top-val*)
(add1 0 0) (add1 0 0)
@ -252,7 +270,7 @@
(with-test-prefix "debug contexts" (with-test-prefix "debug contexts"
(let ((return-3 (assemble-program (let ((return-3 (assemble-program
'((begin-program return-3) '((begin-program return-3 ((name . return-3)))
(assert-nargs-ee/locals 0 1) (assert-nargs-ee/locals 0 1)
(load-constant 0 3) (load-constant 0 3)
(return 0) (return 0)
@ -273,7 +291,7 @@
(pass-if-equal 'foo (pass-if-equal 'foo
(procedure-name (procedure-name
(assemble-program (assemble-program
'((begin-program foo) '((begin-program foo ((name . foo)))
(assert-nargs-ee/locals 0 1) (assert-nargs-ee/locals 0 1)
(load-constant 0 42) (load-constant 0 42)
(return 0) (return 0)