From: Andy Wingo <wingo@pobox.com>
To: guile-devel@gnu.org
Cc: Andy Wingo <wingo@pobox.com>
Subject: [PATCH 1/9] begin-program takes properties alist
Date: Tue, 4 Jun 2013 16:44:02 +0200 [thread overview]
Message-ID: <1370357050-26337-2-git-send-email-wingo@pobox.com> (raw)
In-Reply-To: <1370357050-26337-1-git-send-email-wingo@pobox.com>
* 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
next prev parent reply other threads:[~2013-06-04 14:44 UTC|newest]
Thread overview: 11+ messages / expand[flat|nested] mbox.gz Atom feed top
2013-06-04 14:44 Serialize procedure metadata into ELF for RTL programs Andy Wingo
2013-06-04 14:44 ` Andy Wingo [this message]
2013-06-04 14:44 ` [PATCH 2/9] add procedure prelude macro-instructions Andy Wingo
2013-06-04 14:44 ` [PATCH 3/9] Beginnings of tracking of procedure arities in assembler Andy Wingo
2013-06-04 14:44 ` [PATCH 4/9] RTL assembler writes arities information into separate section Andy Wingo
2013-06-04 14:44 ` [PATCH 5/9] (system vm debug) can read arity information Andy Wingo
2013-06-04 14:44 ` [PATCH 6/9] Wire up ability to print RTL program arities Andy Wingo
2013-06-04 14:44 ` [PATCH 7/9] Write docstrings into RTL ELF images Andy Wingo
2013-06-04 14:44 ` [PATCH 8/9] procedure-documentation works on RTL procedures Andy Wingo
2013-06-04 14:44 ` [PATCH 9/9] procedure-properties for RTL functions Andy Wingo
2013-06-04 15:06 ` Nala Ginrut
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=1370357050-26337-2-git-send-email-wingo@pobox.com \
--to=wingo@pobox.com \
--cc=guile-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).