unofficial mirror of guile-devel@gnu.org 
 help / color / mirror / Atom feed
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




  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).