begin-program takes properties alist

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

2 files changed, 62 insertions, 27 deletions

diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 7eb60492a..b355b851d 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 8429512c5..2f5918fd0 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)