From 2a4daafd303f9b70d0680a4cadf42ef5c3fcfabc Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 14 May 2013 10:25:38 +0200 Subject: [PATCH] begin-program takes properties alist * module/system/vm/assembler.scm (assert-match): New helper macro to check argument types. (): 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 | 29 +++++++++++++---- test-suite/tests/rtl.test | 58 ++++++++++++++++++++++------------ 2 files changed, 60 insertions(+), 27 deletions(-) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 0a35bdc99..d92f7c432 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -110,13 +110,27 @@ ;;; A entry collects metadata for one procedure. Procedures are ;;; 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 - (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) + (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)) ;;; 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)))) (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)))) @@ -686,7 +701,7 @@ a procedure to do that and return its label. Otherwise return (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*) @@ -1025,7 +1040,7 @@ it will be added to the GC roots at runtime." (strtab (make-string-table)) (bv (make-bytevector (* n size) 0))) (define (intern-string! name) - (string-table-intern! strtab (symbol->string name))) + (string-table-intern! strtab (if name (symbol->string name) ""))) (for-each (lambda (meta n) (let ((name (intern-string! (meta-name meta)))) 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) -- 2.20.1