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 3/9] Beginnings of tracking of procedure arities in assembler Date: Tue, 4 Jun 2013 16:44:04 +0200 Message-ID: <1370357050-26337-4-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 1370357106 3724 80.91.229.3 (4 Jun 2013 14:45:06 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Tue, 4 Jun 2013 14:45:06 +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:06 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 1UjsTw-0000kM-R8 for guile-devel@m.gmane.org; Tue, 04 Jun 2013 16:45:05 +0200 Original-Received: from localhost ([::1]:51748 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UjsTw-0006kV-5C for guile-devel@m.gmane.org; Tue, 04 Jun 2013 10:45:04 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:55150) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UjsTj-0006T7-0O for guile-devel@gnu.org; Tue, 04 Jun 2013 10:44:54 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1UjsTe-0001vA-FM for guile-devel@gnu.org; Tue, 04 Jun 2013 10:44:50 -0400 Original-Received: from a-pb-sasl-quonix.pobox.com ([208.72.237.25]:58464 helo=sasl.smtp.pobox.com) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UjsTe-0001v4-9V for guile-devel@gnu.org; Tue, 04 Jun 2013 10:44:46 -0400 Original-Received: from sasl.smtp.pobox.com (unknown [127.0.0.1]) by a-pb-sasl-quonix.pobox.com (Postfix) with ESMTP id 00085C814; Tue, 4 Jun 2013 10:44:45 -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=M619 3oaNofCURwgpUjLK8YwalKE=; b=GEZcSqKN4pOStX2Xh1Kwv2wIck/wNgVPHpY2 of7vwK0ju7IRlkhz63CBisCBwndp8rj+c9oysySGzG4jdJ9fNGdxXD128avSKxEa nzln7rwlvwrHQLh3g3jHvSJtSIv61kXqST1RAWKMHzB/8caOcdxiVtWZDy9AtrKS xB8Ip5c= 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= U5x8Yn72dzq2WvqIwtIDS6VfS0gEFapyDwavbcJkRJ5IxQHSNTqGc+NZoyEQP5Kn Kg1N5ELrPJsm5FtHKvYqzq9LO5B5fetVd5RI32Ifszd1bl+PJ9fVO77xcgmehn75 TLRs8JLrHtUiAqnDR0k2pgKZ3A3dbc8ziMgE9vTGCrs= 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 EA2AAC813; Tue, 4 Jun 2013 10:44:45 -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 8C7FDC812; Tue, 4 Jun 2013 10:44:43 -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: 4C163F28-CD25-11E2-811C-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:16460 Archived-At: * module/system/vm/assembler.scm (, ): Assembler now tracks arities of a function. (begin-standard-arity, begin-opt-arity, begin-kw-arity, end-arity): New macro-assemblers. * test-suite/tests/rtl.test: Adapt all tests to use begin-standard-arity and end-arity. --- module/system/vm/assembler.scm | 59 ++++++++++++++++++++++++++++++++++++--- test-suite/tests/rtl.test | 60 ++++++++++++++++++++++++++-------------- 2 files changed, 95 insertions(+), 24 deletions(-) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 9538d71..47f31ed 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -72,21 +72,35 @@ (error (string-append "expected " kind) x)))) (define-record-type - (%make-meta label properties low-pc high-pc) + (%make-meta label properties low-pc high-pc arities) meta? (label meta-label) (properties meta-properties set-meta-properties!) (low-pc meta-low-pc) - (high-pc meta-high-pc set-meta-high-pc!)) + (high-pc meta-high-pc set-meta-high-pc!) + (arities meta-arities set-meta-arities!)) (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)) + (%make-meta label properties low-pc #f '())) (define (meta-name meta) (assq-ref (meta-properties meta) 'name)) +;; Metadata for one . +(define-record-type + (make-arity req opt rest kw-indices allow-other-keys? + low-pc high-pc) + arity? + (req arity-req) + (opt arity-opt) + (rest arity-rest) + (kw-indices arity-kw-indices) + (allow-other-keys? arity-allow-other-keys?) + (low-pc arity-low-pc) + (high-pc arity-high-pc set-arity-high-pc!)) + (define-syntax *block-size* (identifier-syntax 32)) ;; We'll use native endianness when writing bytecode. If we're @@ -463,7 +477,44 @@ (define-macro-assembler (end-program asm) (let ((meta (car (asm-meta asm)))) - (set-meta-high-pc! meta (asm-start asm)))) + (set-meta-high-pc! meta (asm-start asm)) + (set-meta-arities! meta (reverse (meta-arities meta))))) + +(define-macro-assembler (begin-standard-arity asm req nlocals alternate) + (emit-begin-opt-arity asm req '() #f nlocals alternate)) + +(define-macro-assembler (begin-opt-arity asm req opt rest nlocals alternate) + (emit-begin-kw-arity asm req opt rest '() #f nlocals alternate)) + +(define-macro-assembler (begin-kw-arity asm req opt rest kw-indices + allow-other-keys? nlocals alternate) + (check req ((? symbol?) ...) "list of symbols") + (check opt ((? symbol?) ...) "list of symbols") + (check rest (or #f (? symbol?)) "#f or symbol") + (check kw-indices (((? symbol?) . (? integer?)) ...) + "alist of symbol -> integer") + (check allow-other-keys? (? boolean?) "boolean") + (check nlocals (? integer?) "integer") + (check alternate (or #f (? symbol?)) "#f or symbol") + (let* ((meta (car (asm-meta asm))) + (arity (make-arity req opt rest kw-indices allow-other-keys? + (asm-start asm) #f)) + (nreq (length req)) + (nopt (length opt)) + (rest? (->bool rest))) + (set-meta-arities! meta (cons arity (meta-arities meta))) + (cond + ((or allow-other-keys? (pair? kw-indices)) + (emit-kw-prelude asm nreq nopt rest? kw-indices allow-other-keys? + nlocals alternate)) + ((or rest? (pair? opt)) + (emit-opt-prelude asm nreq nopt rest? nlocals alternate)) + (else + (emit-standard-prelude asm nreq nlocals alternate))))) + +(define-macro-assembler (end-arity asm) + (let ((arity (car (meta-arities (car (asm-meta asm)))))) + (set-arity-high-pc! arity (asm-start asm)))) (define-macro-assembler (standard-prelude asm nreq nlocals alternate) (cond diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test index 02e6993..1813969 100644 --- a/test-suite/tests/rtl.test +++ b/test-suite/tests/rtl.test @@ -29,9 +29,10 @@ (define (return-constant val) (assemble-program `((begin-program foo ((name . foo))) - (standard-prelude 0 1 #f) + (begin-standard-arity () 1 #f) (load-constant 0 ,val) (return 0) + (end-arity) (end-program)))) (define-syntax-rule (assert-constants val ...) @@ -66,15 +67,17 @@ (assert-equal 42 (((assemble-program `((begin-program foo ((name . foo))) - (standard-prelude 0 1 #f) + (begin-standard-arity () 1 #f) (load-static-procedure 0 bar) (return 0) + (end-arity) (end-program) (begin-program bar ((name . bar))) - (standard-prelude 0 1 #f) + (begin-standard-arity () 1 #f) (load-constant 0 42) (return 0) + (end-arity) (end-program))))))) (with-test-prefix "loop" @@ -86,7 +89,7 @@ ;; 2: accum '((begin-program countdown ((name . countdown))) - (standard-prelude 1 3 #f) + (begin-standard-arity (x) 3 #f) (br fix-body) (label loop-head) (br-if-= 1 0 out) @@ -99,6 +102,7 @@ (br loop-head) (label out) (return 2) + (end-arity) (end-program))))) (sumto 1000)))) @@ -111,20 +115,22 @@ ;; 2: head '((begin-program make-accum ((name . make-accum))) - (standard-prelude 0 2 #f) + (begin-standard-arity () 2 #f) (load-constant 0 0) (box 0 0) (make-closure 1 accum (0)) (return 1) + (end-arity) (end-program) (begin-program accum ((name . accum))) - (standard-prelude 1 3 #f) + (begin-standard-arity (x) 3 #f) (free-ref 1 0) (box-ref 2 1) (add 2 2 0) (box-set! 1 2) (return 2) + (end-arity) (end-program))))) (let ((accum (make-accum))) (accum 1) @@ -137,10 +143,11 @@ (assemble-program '((begin-program call ((name . call))) - (standard-prelude 1 1 #f) + (begin-standard-arity (f) 1 #f) (call 1 0 ()) (return 1) ;; MVRA from call (return 1) ;; RA from call + (end-arity) (end-program))))) (call (lambda () 42)))) @@ -149,11 +156,12 @@ (assemble-program '((begin-program call-with-3 ((name . call-with-3))) - (standard-prelude 1 2 #f) + (begin-standard-arity (f) 2 #f) (load-constant 1 3) (call 2 0 (1)) (return 2) ;; MVRA from call (return 2) ;; RA from call + (end-arity) (end-program))))) (call-with-3 (lambda (x) (* x 2)))))) @@ -163,8 +171,9 @@ (assemble-program '((begin-program call ((name . call))) - (standard-prelude 1 1 #f) + (begin-standard-arity (f) 1 #f) (tail-call 0 0) + (end-arity) (end-program))))) (call (lambda () 3)))) @@ -173,10 +182,11 @@ (assemble-program '((begin-program call-with-3 ((name . call-with-3))) - (standard-prelude 1 2 #f) + (begin-standard-arity (f) 2 #f) (mov 1 0) ;; R1 <- R0 (load-constant 0 3) ;; R0 <- 3 (tail-call 1 1) + (end-arity) (end-program))))) (call-with-3 (lambda (x) (* x 2)))))) @@ -186,17 +196,19 @@ (assemble-program '((begin-program get-sqrt-trampoline ((name . get-sqrt-trampoline))) - (standard-prelude 0 1 #f) + (begin-standard-arity () 1 #f) (cache-current-module! 0 sqrt-scope) (load-static-procedure 0 sqrt-trampoline) (return 0) + (end-arity) (end-program) (begin-program sqrt-trampoline ((name . sqrt-trampoline))) - (standard-prelude 1 2 #f) + (begin-standard-arity (x) 2 #f) (cached-toplevel-ref 1 sqrt-scope sqrt) (tail-call 1 1) + (end-arity) (end-program))))) ((get-sqrt-trampoline) 25.0)))) @@ -209,19 +221,21 @@ (assemble-program '((begin-program make-top-incrementor ((name . make-top-incrementor))) - (standard-prelude 0 1 #f) + (begin-standard-arity () 1 #f) (cache-current-module! 0 top-incrementor) (load-static-procedure 0 top-incrementor) (return 0) + (end-arity) (end-program) (begin-program top-incrementor ((name . top-incrementor))) - (standard-prelude 0 1 #f) + (begin-standard-arity () 1 #f) (cached-toplevel-ref 0 top-incrementor *top-val*) (add1 0 0) (cached-toplevel-set! 0 top-incrementor *top-val*) (return/values 0) + (end-arity) (end-program))))) ((make-top-incrementor)) *top-val*)))) @@ -232,16 +246,18 @@ (assemble-program '((begin-program get-sqrt-trampoline ((name . get-sqrt-trampoline))) - (standard-prelude 0 1 #f) + (begin-standard-arity () 1 #f) (load-static-procedure 0 sqrt-trampoline) (return 0) + (end-arity) (end-program) (begin-program sqrt-trampoline ((name . sqrt-trampoline))) - (standard-prelude 1 2 #f) + (begin-standard-arity (x) 2 #f) (cached-module-ref 1 (guile) #t sqrt) (tail-call 1 1) + (end-arity) (end-program))))) ((get-sqrt-trampoline) 25.0)))) @@ -252,18 +268,20 @@ (assemble-program '((begin-program make-top-incrementor ((name . make-top-incrementor))) - (standard-prelude 0 1 #f) + (begin-standard-arity () 1 #f) (load-static-procedure 0 top-incrementor) (return 0) + (end-arity) (end-program) (begin-program top-incrementor ((name . top-incrementor))) - (standard-prelude 0 1 #f) + (begin-standard-arity () 1 #f) (cached-module-ref 0 (tests rtl) #f *top-val*) (add1 0 0) (cached-module-set! 0 (tests rtl) #f *top-val*) (return 0) + (end-arity) (end-program))))) ((make-top-incrementor)) *top-val*)))) @@ -271,9 +289,10 @@ (with-test-prefix "debug contexts" (let ((return-3 (assemble-program '((begin-program return-3 ((name . return-3))) - (standard-prelude 0 1 #f) + (begin-standard-arity () 1 #f) (load-constant 0 3) (return 0) + (end-arity) (end-program))))) (pass-if "program name" (and=> (find-program-debug-info (rtl-program-code return-3)) @@ -292,7 +311,8 @@ (procedure-name (assemble-program '((begin-program foo ((name . foo))) - (standard-prelude 0 1 #f) + (begin-standard-arity () 1 #f) (load-constant 0 42) (return 0) + (end-arity) (end-program)))))) -- 1.7.10.4