[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH 1/9] begin-program takes properties alist
|
From: |
Andy Wingo |
|
Subject: |
[PATCH 1/9] begin-program takes properties alist |
|
Date: |
Tue, 4 Jun 2013 16:44:02 +0200 |
* module/system/vm/assembler.scm (check): 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.
---
module/system/vm/assembler.scm | 31 ++++++++++++++++-----
test-suite/tests/rtl.test | 58 ++++++++++++++++++++++++++--------------
2 files changed, 62 insertions(+), 27 deletions(-)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 7eb6049..b355b85 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -26,6 +26,7 @@
#:use-module (system vm objcode)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 vlist)
+ #:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-4)
#:use-module (srfi srfi-9)
@@ -59,13 +60,27 @@
(define-syntax-rule (pack-u8-u8-u8-u8 x y z w)
(logior x (ash y 8) (ash z 16) (ash w 24)))
+(define-syntax-rule (check 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)
+ (check label (? symbol?) "symbol")
+ (check 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))
;; We'll use native endianness when writing bytecode. If we're
@@ -435,13 +450,14 @@
(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))))
@@ -623,7 +639,7 @@
(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*)
@@ -821,7 +837,8 @@
(bv (make-bytevector (* n size) 0)))
(define (intern-string! name)
(call-with-values
- (lambda () (string-table-intern strtab (symbol->string name)))
+ (lambda () (string-table-intern strtab
+ (if name (symbol->string name) "")))
(lambda (table idx)
(set! strtab table)
idx)))
diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test
index 8429512..2f5918f 100644
--- a/test-suite/tests/rtl.test
+++ b/test-suite/tests/rtl.test
@@ -27,7 +27,8 @@
(pass-if (object->string x) (equal? expr x))))
(define (return-constant val)
- (assemble-program `((begin-program foo)
+ (assemble-program `((begin-program foo
+ ((name . foo)))
(assert-nargs-ee/locals 0 1)
(load-constant 0 ,val)
(return 0)
@@ -63,12 +64,14 @@
(with-test-prefix "static procedure"
(assert-equal 42
- (((assemble-program `((begin-program foo)
+ (((assemble-program `((begin-program foo
+ ((name . foo)))
(assert-nargs-ee/locals 0 1)
(load-static-procedure 0 bar)
(return 0)
(end-program)
- (begin-program bar)
+ (begin-program bar
+ ((name . bar)))
(assert-nargs-ee/locals 0 1)
(load-constant 0 42)
(return 0)
@@ -81,7 +84,8 @@
;; 0: limit
;; 1: n
;; 2: accum
- '((begin-program countdown)
+ '((begin-program countdown
+ ((name . countdown)))
(assert-nargs-ee/locals 1 2)
(br fix-body)
(label loop-head)
@@ -105,14 +109,16 @@
;; 0: elt
;; 1: tail
;; 2: head
- '((begin-program make-accum)
+ '((begin-program make-accum
+ ((name . make-accum)))
(assert-nargs-ee/locals 0 2)
(load-constant 0 0)
(box 0 0)
(make-closure 1 accum (0))
(return 1)
(end-program)
- (begin-program accum)
+ (begin-program accum
+ ((name . accum)))
(assert-nargs-ee/locals 1 2)
(free-ref 1 0)
(box-ref 2 1)
@@ -129,7 +135,8 @@
(assert-equal 42
(let ((call ;; (lambda (x) (x))
(assemble-program
- '((begin-program call)
+ '((begin-program call
+ ((name . call)))
(assert-nargs-ee/locals 1 0)
(call 1 0 ())
(return 1) ;; MVRA from call
@@ -140,7 +147,8 @@
(assert-equal 6
(let ((call-with-3 ;; (lambda (x) (x 3))
(assemble-program
- '((begin-program call-with-3)
+ '((begin-program call-with-3
+ ((name . call-with-3)))
(assert-nargs-ee/locals 1 1)
(load-constant 1 3)
(call 2 0 (1))
@@ -153,7 +161,8 @@
(assert-equal 3
(let ((call ;; (lambda (x) (x))
(assemble-program
- '((begin-program call)
+ '((begin-program call
+ ((name . call)))
(assert-nargs-ee/locals 1 0)
(tail-call 0 0)
(end-program)))))
@@ -162,7 +171,8 @@
(assert-equal 6
(let ((call-with-3 ;; (lambda (x) (x 3))
(assemble-program
- '((begin-program call-with-3)
+ '((begin-program call-with-3
+ ((name . call-with-3)))
(assert-nargs-ee/locals 1 1)
(mov 1 0) ;; R1 <- R0
(load-constant 0 3) ;; R0 <- 3
@@ -174,14 +184,16 @@
(assert-equal 5.0
(let ((get-sqrt-trampoline
(assemble-program
- '((begin-program get-sqrt-trampoline)
+ '((begin-program get-sqrt-trampoline
+ ((name . get-sqrt-trampoline)))
(assert-nargs-ee/locals 0 1)
(cache-current-module! 0 sqrt-scope)
(load-static-procedure 0 sqrt-trampoline)
(return 0)
(end-program)
- (begin-program sqrt-trampoline)
+ (begin-program sqrt-trampoline
+ ((name . sqrt-trampoline)))
(assert-nargs-ee/locals 1 1)
(cached-toplevel-ref 1 sqrt-scope sqrt)
(tail-call 1 1)
@@ -195,14 +207,16 @@
(assert-equal (1+ prev)
(let ((make-top-incrementor
(assemble-program
- '((begin-program make-top-incrementor)
+ '((begin-program make-top-incrementor
+ ((name . make-top-incrementor)))
(assert-nargs-ee/locals 0 1)
(cache-current-module! 0 top-incrementor)
(load-static-procedure 0 top-incrementor)
(return 0)
(end-program)
- (begin-program top-incrementor)
+ (begin-program top-incrementor
+ ((name . top-incrementor)))
(assert-nargs-ee/locals 0 1)
(cached-toplevel-ref 0 top-incrementor *top-val*)
(add1 0 0)
@@ -216,13 +230,15 @@
(assert-equal 5.0
(let ((get-sqrt-trampoline
(assemble-program
- '((begin-program get-sqrt-trampoline)
+ '((begin-program get-sqrt-trampoline
+ ((name . get-sqrt-trampoline)))
(assert-nargs-ee/locals 0 1)
(load-static-procedure 0 sqrt-trampoline)
(return 0)
(end-program)
- (begin-program sqrt-trampoline)
+ (begin-program sqrt-trampoline
+ ((name . sqrt-trampoline)))
(assert-nargs-ee/locals 1 1)
(cached-module-ref 1 (guile) #t sqrt)
(tail-call 1 1)
@@ -234,13 +250,15 @@
(assert-equal (1+ prev)
(let ((make-top-incrementor
(assemble-program
- '((begin-program make-top-incrementor)
+ '((begin-program make-top-incrementor
+ ((name . make-top-incrementor)))
(assert-nargs-ee/locals 0 1)
(load-static-procedure 0 top-incrementor)
(return 0)
(end-program)
- (begin-program top-incrementor)
+ (begin-program top-incrementor
+ ((name . top-incrementor)))
(assert-nargs-ee/locals 0 1)
(cached-module-ref 0 (tests rtl) #f *top-val*)
(add1 0 0)
@@ -252,7 +270,7 @@
(with-test-prefix "debug contexts"
(let ((return-3 (assemble-program
- '((begin-program return-3)
+ '((begin-program return-3 ((name . return-3)))
(assert-nargs-ee/locals 0 1)
(load-constant 0 3)
(return 0)
@@ -273,7 +291,7 @@
(pass-if-equal 'foo
(procedure-name
(assemble-program
- '((begin-program foo)
+ '((begin-program foo ((name . foo)))
(assert-nargs-ee/locals 0 1)
(load-constant 0 42)
(return 0)
--
1.7.10.4
- Serialize procedure metadata into ELF for RTL programs, Andy Wingo, 2013/06/04
- [PATCH 2/9] add procedure prelude macro-instructions, Andy Wingo, 2013/06/04
- [PATCH 3/9] Beginnings of tracking of procedure arities in assembler, Andy Wingo, 2013/06/04
- [PATCH 1/9] begin-program takes properties alist,
Andy Wingo <=
- [PATCH 4/9] RTL assembler writes arities information into separate section., Andy Wingo, 2013/06/04
- [PATCH 6/9] Wire up ability to print RTL program arities, Andy Wingo, 2013/06/04
- [PATCH 5/9] (system vm debug) can read arity information, Andy Wingo, 2013/06/04
- [PATCH 7/9] Write docstrings into RTL ELF images, Andy Wingo, 2013/06/04
- [PATCH 8/9] procedure-documentation works on RTL procedures, Andy Wingo, 2013/06/04
- [PATCH 9/9] procedure-properties for RTL functions, Andy Wingo, 2013/06/04