From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Andy Wingo Newsgroups: gmane.lisp.guile.devel Subject: [PATCH 1/9] begin-program takes properties alist Date: Tue, 4 Jun 2013 16:44:02 +0200 Message-ID: <1370357050-26337-2-git-send-email-wingo@pobox.com> References: <1370357050-26337-1-git-send-email-wingo@pobox.com> NNTP-Posting-Host: plane.gmane.org X-Trace: ger.gmane.org 1370357101 3642 80.91.229.3 (4 Jun 2013 14:45:01 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Tue, 4 Jun 2013 14:45:01 +0000 (UTC) Cc: Andy Wingo To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Tue Jun 04 16:45:01 2013 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1UjsTs-0000gr-8M for guile-devel@m.gmane.org; Tue, 04 Jun 2013 16:45:00 +0200 Original-Received: from localhost ([::1]:51508 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UjsTr-0006c4-TQ for guile-devel@m.gmane.org; Tue, 04 Jun 2013 10:44:59 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:55104) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UjsTf-0006L9-W8 for guile-devel@gnu.org; Tue, 04 Jun 2013 10:44:55 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1UjsTZ-0001t4-1J for guile-devel@gnu.org; Tue, 04 Jun 2013 10:44:47 -0400 Original-Received: from a-pb-sasl-quonix.pobox.com ([208.72.237.25]:58241 helo=sasl.smtp.pobox.com) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UjsTY-0001sw-Rz for guile-devel@gnu.org; Tue, 04 Jun 2013 10:44:40 -0400 Original-Received: from sasl.smtp.pobox.com (unknown [127.0.0.1]) by a-pb-sasl-quonix.pobox.com (Postfix) with ESMTP id 8CA70C80E; Tue, 4 Jun 2013 10:44:40 -0400 (EDT) DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to:cc :subject:date:message-id:in-reply-to:references; s=sasl; bh=TIRM LxSHYROIbiuXNBBNZxihsr8=; b=QUe+tC975J1qo+1bXbI6FOU6gU06oRu1fcKB VZhI19rXcgfmd9tKpTgLqYE4xdy5bHlbaxHDhitNeHYFVbA6ayVJ3zVmQrJr2mrz HTLxrK5/QrZ3G3asFm1/qwEb8muXBQ83BSt27J0StE8lPXYSe69M9+PkDp6iUj2v DKta3aQ= DomainKey-Signature: a=rsa-sha1; c=nofws; d=pobox.com; h=from:to:cc :subject:date:message-id:in-reply-to:references; q=dns; s=sasl; b= dQB4TPAdZw+uN4Aes39gHqiF6y794AfLjzcO5cAKBxTrVEJLK5FCv4YFlCB5M2IK M9rt6ntcPaYht8+iNkiVb0bulzsTZaj3h/BCwUrQ4LBFbB60oIicDuHEfYROtzC1 QIoxtTslgFFIlHV/EwWDK4Sx/NXikvXK2RC/VumUXSU= Original-Received: from a-pb-sasl-quonix.pobox.com (unknown [127.0.0.1]) by a-pb-sasl-quonix.pobox.com (Postfix) with ESMTP id 823E2C80D; Tue, 4 Jun 2013 10:44:40 -0400 (EDT) Original-Received: from localhost.localdomain (unknown [88.5.174.195]) (using TLSv1 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (No client certificate requested) by a-pb-sasl-quonix.pobox.com (Postfix) with ESMTPSA id 19F3BC80C; Tue, 4 Jun 2013 10:44:37 -0400 (EDT) X-Mailer: git-send-email 1.7.10.4 In-Reply-To: <1370357050-26337-1-git-send-email-wingo@pobox.com> X-Pobox-Relay-ID: 48DDF3E6-CD25-11E2-93B0-9F710E5B5709-02397024!a-pb-sasl-quonix.pobox.com X-detected-operating-system: by eggs.gnu.org: Solaris 10 X-Received-From: 208.72.237.25 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:16459 Archived-At: * module/system/vm/assembler.scm (check): 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 | 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 - (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