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 2/9] add procedure prelude macro-instructions Date: Tue, 4 Jun 2013 16:44:03 +0200 Message-ID: <1370357050-26337-3-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 1370357095 3577 80.91.229.3 (4 Jun 2013 14:44:55 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Tue, 4 Jun 2013 14:44:55 +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:44:55 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 1UjsTm-0000bO-Ut for guile-devel@m.gmane.org; Tue, 04 Jun 2013 16:44:55 +0200 Original-Received: from localhost ([::1]:51391 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UjsTm-0006Xm-Jh for guile-devel@m.gmane.org; Tue, 04 Jun 2013 10:44:54 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:55085) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UjsTe-0006IM-EO for guile-devel@gnu.org; Tue, 04 Jun 2013 10:44:51 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1UjsTb-0001tY-KG for guile-devel@gnu.org; Tue, 04 Jun 2013 10:44:46 -0400 Original-Received: from a-pb-sasl-quonix.pobox.com ([208.72.237.25]:58333 helo=sasl.smtp.pobox.com) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UjsTb-0001tT-GE for guile-devel@gnu.org; Tue, 04 Jun 2013 10:44:43 -0400 Original-Received: from sasl.smtp.pobox.com (unknown [127.0.0.1]) by a-pb-sasl-quonix.pobox.com (Postfix) with ESMTP id 3AE3AC811; Tue, 4 Jun 2013 10:44:43 -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=u1er bL9331Cb4Ua8KinxKMZkkuc=; b=p8aJlGH8+MTVDMQsmfGeBQM4nstE0Y95Wkgv gP7zKl7y7hsHrDDKlfH96KdaFf5+7MkuhT0gLCPURbD+QeaBTtvOnrIqinxGo0Ga g9n78aYCgm7gRBEN79ROLILOclTOJMndiCR15j1OBIVAnnMqDCbfWzmU3BoQsGHU ZznyiRk= 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= Rwe1XaFdurTv2TcINu9EDANWnlPXtP5/7K2O+1qRZqzyO3jx97973m2/rH53roIH 54JOOZi72H21XCaByHOA5snaCnOgBFhK3fyFjHv1iyysOcOjs3GVzfcnyZUSL2wm BHMANywxtXuz87dzsnXloReOMP5OxlJwUOfvQ3l6fMg= 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 30F5FC810; Tue, 4 Jun 2013 10:44:43 -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 A8C87C80F; Tue, 4 Jun 2013 10:44:40 -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: 4A6DD730-CD25-11E2-AAD5-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:16458 Archived-At: * module/system/vm/assembler.scm (pack-flags): New helper. (standard-prelude, opt-prelude, kw-prelude): New macro-instructions. * test-suite/tests/rtl.test: Update tests to use standard-prelude. --- module/system/vm/assembler.scm | 48 ++++++++++++++++++++++++++++++++++++++++ test-suite/tests/rtl.test | 40 ++++++++++++++++----------------- 2 files changed, 68 insertions(+), 20 deletions(-) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index b355b85..9538d71 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -36,6 +36,12 @@ link-assembly assemble-program)) +(define-syntax pack-flags + (syntax-rules () + ;; Add clauses as needed. + ((pack-flags f1 f2) (logior (if f1 (ash 1 0) 0) + (if f2 (ash 2 0) 0))))) + (define-syntax-rule (pack-u8-u24 x y) (logior x (ash y 8))) @@ -459,6 +465,48 @@ (let ((meta (car (asm-meta asm)))) (set-meta-high-pc! meta (asm-start asm)))) +(define-macro-assembler (standard-prelude asm nreq nlocals alternate) + (cond + (alternate + (emit-br-if-nargs-ne asm nreq alternate) + (emit-reserve-locals asm nlocals)) + ((and (< nreq (ash 1 12)) (< (- nlocals nreq) (ash 1 12))) + (emit-assert-nargs-ee/locals asm nreq (- nlocals nreq))) + (else + (emit-assert-nargs-ee asm nreq) + (emit-reserve-locals asm nlocals)))) + +(define-macro-assembler (opt-prelude asm nreq nopt rest? nlocals alternate) + (if alternate + (emit-br-if-nargs-lt asm nreq alternate) + (emit-assert-nargs-ge asm nreq)) + (cond + (rest? + (emit-bind-rest asm (+ nreq nopt))) + (alternate + (emit-br-if-nargs-gt asm (+ nreq nopt) alternate)) + (else + (emit-assert-nargs-le asm (+ nreq nopt)))) + (emit-reserve-locals asm nlocals)) + +(define-macro-assembler (kw-prelude asm nreq nopt rest? kw-indices + allow-other-keys? nlocals alternate) + (if alternate + (emit-br-if-nargs-lt asm nreq alternate) + (emit-assert-nargs-ge asm nreq)) + (let ((ntotal (fold (lambda (kw ntotal) + (match kw + (((? keyword?) . idx) + (max (1+ idx) ntotal)))) + (+ nreq nopt) kw-indices))) + ;; FIXME: port 581f410f + (emit-bind-kwargs asm nreq + (pack-flags allow-other-keys? rest?) + (+ nreq nopt) + ntotal + kw-indices) + (emit-reserve-locals asm nlocals))) + (define-macro-assembler (label asm sym) (set-asm-labels! asm (acons sym (asm-start asm) (asm-labels asm)))) diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test index 2f5918f..02e6993 100644 --- a/test-suite/tests/rtl.test +++ b/test-suite/tests/rtl.test @@ -29,7 +29,7 @@ (define (return-constant val) (assemble-program `((begin-program foo ((name . foo))) - (assert-nargs-ee/locals 0 1) + (standard-prelude 0 1 #f) (load-constant 0 ,val) (return 0) (end-program)))) @@ -66,13 +66,13 @@ (assert-equal 42 (((assemble-program `((begin-program foo ((name . foo))) - (assert-nargs-ee/locals 0 1) + (standard-prelude 0 1 #f) (load-static-procedure 0 bar) (return 0) (end-program) (begin-program bar ((name . bar))) - (assert-nargs-ee/locals 0 1) + (standard-prelude 0 1 #f) (load-constant 0 42) (return 0) (end-program))))))) @@ -86,7 +86,7 @@ ;; 2: accum '((begin-program countdown ((name . countdown))) - (assert-nargs-ee/locals 1 2) + (standard-prelude 1 3 #f) (br fix-body) (label loop-head) (br-if-= 1 0 out) @@ -111,7 +111,7 @@ ;; 2: head '((begin-program make-accum ((name . make-accum))) - (assert-nargs-ee/locals 0 2) + (standard-prelude 0 2 #f) (load-constant 0 0) (box 0 0) (make-closure 1 accum (0)) @@ -119,7 +119,7 @@ (end-program) (begin-program accum ((name . accum))) - (assert-nargs-ee/locals 1 2) + (standard-prelude 1 3 #f) (free-ref 1 0) (box-ref 2 1) (add 2 2 0) @@ -137,7 +137,7 @@ (assemble-program '((begin-program call ((name . call))) - (assert-nargs-ee/locals 1 0) + (standard-prelude 1 1 #f) (call 1 0 ()) (return 1) ;; MVRA from call (return 1) ;; RA from call @@ -149,7 +149,7 @@ (assemble-program '((begin-program call-with-3 ((name . call-with-3))) - (assert-nargs-ee/locals 1 1) + (standard-prelude 1 2 #f) (load-constant 1 3) (call 2 0 (1)) (return 2) ;; MVRA from call @@ -163,7 +163,7 @@ (assemble-program '((begin-program call ((name . call))) - (assert-nargs-ee/locals 1 0) + (standard-prelude 1 1 #f) (tail-call 0 0) (end-program))))) (call (lambda () 3)))) @@ -173,7 +173,7 @@ (assemble-program '((begin-program call-with-3 ((name . call-with-3))) - (assert-nargs-ee/locals 1 1) + (standard-prelude 1 2 #f) (mov 1 0) ;; R1 <- R0 (load-constant 0 3) ;; R0 <- 3 (tail-call 1 1) @@ -186,7 +186,7 @@ (assemble-program '((begin-program get-sqrt-trampoline ((name . get-sqrt-trampoline))) - (assert-nargs-ee/locals 0 1) + (standard-prelude 0 1 #f) (cache-current-module! 0 sqrt-scope) (load-static-procedure 0 sqrt-trampoline) (return 0) @@ -194,7 +194,7 @@ (begin-program sqrt-trampoline ((name . sqrt-trampoline))) - (assert-nargs-ee/locals 1 1) + (standard-prelude 1 2 #f) (cached-toplevel-ref 1 sqrt-scope sqrt) (tail-call 1 1) (end-program))))) @@ -209,7 +209,7 @@ (assemble-program '((begin-program make-top-incrementor ((name . make-top-incrementor))) - (assert-nargs-ee/locals 0 1) + (standard-prelude 0 1 #f) (cache-current-module! 0 top-incrementor) (load-static-procedure 0 top-incrementor) (return 0) @@ -217,7 +217,7 @@ (begin-program top-incrementor ((name . top-incrementor))) - (assert-nargs-ee/locals 0 1) + (standard-prelude 0 1 #f) (cached-toplevel-ref 0 top-incrementor *top-val*) (add1 0 0) (cached-toplevel-set! 0 top-incrementor *top-val*) @@ -232,14 +232,14 @@ (assemble-program '((begin-program get-sqrt-trampoline ((name . get-sqrt-trampoline))) - (assert-nargs-ee/locals 0 1) + (standard-prelude 0 1 #f) (load-static-procedure 0 sqrt-trampoline) (return 0) (end-program) (begin-program sqrt-trampoline ((name . sqrt-trampoline))) - (assert-nargs-ee/locals 1 1) + (standard-prelude 1 2 #f) (cached-module-ref 1 (guile) #t sqrt) (tail-call 1 1) (end-program))))) @@ -252,14 +252,14 @@ (assemble-program '((begin-program make-top-incrementor ((name . make-top-incrementor))) - (assert-nargs-ee/locals 0 1) + (standard-prelude 0 1 #f) (load-static-procedure 0 top-incrementor) (return 0) (end-program) (begin-program top-incrementor ((name . top-incrementor))) - (assert-nargs-ee/locals 0 1) + (standard-prelude 0 1 #f) (cached-module-ref 0 (tests rtl) #f *top-val*) (add1 0 0) (cached-module-set! 0 (tests rtl) #f *top-val*) @@ -271,7 +271,7 @@ (with-test-prefix "debug contexts" (let ((return-3 (assemble-program '((begin-program return-3 ((name . return-3))) - (assert-nargs-ee/locals 0 1) + (standard-prelude 0 1 #f) (load-constant 0 3) (return 0) (end-program))))) @@ -292,7 +292,7 @@ (procedure-name (assemble-program '((begin-program foo ((name . foo))) - (assert-nargs-ee/locals 0 1) + (standard-prelude 0 1 #f) (load-constant 0 42) (return 0) (end-program)))))) -- 1.7.10.4