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 6/9] Wire up ability to print RTL program arities Date: Tue, 4 Jun 2013 16:44:07 +0200 Message-ID: <1370357050-26337-7-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 1370357110 3790 80.91.229.3 (4 Jun 2013 14:45:10 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Tue, 4 Jun 2013 14:45:10 +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:11 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 1UjsU2-0000ob-51 for guile-devel@m.gmane.org; Tue, 04 Jun 2013 16:45:10 +0200 Original-Received: from localhost ([::1]:52087 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UjsU1-0006xr-4p for guile-devel@m.gmane.org; Tue, 04 Jun 2013 10:45:09 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:55235) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UjsTp-0006f1-9S for guile-devel@gnu.org; Tue, 04 Jun 2013 10:45:04 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1UjsTl-0001xl-Iz for guile-devel@gnu.org; Tue, 04 Jun 2013 10:44:57 -0400 Original-Received: from a-pb-sasl-quonix.pobox.com ([208.72.237.25]:58777 helo=sasl.smtp.pobox.com) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UjsTl-0001xZ-C5 for guile-devel@gnu.org; Tue, 04 Jun 2013 10:44:53 -0400 Original-Received: from sasl.smtp.pobox.com (unknown [127.0.0.1]) by a-pb-sasl-quonix.pobox.com (Postfix) with ESMTP id 1D7DAC820; Tue, 4 Jun 2013 10:44:53 -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=vDef TaVRbbIc7gQ0c26KlBbyYkw=; b=X5yj9+8QVF8ej5bM6zxPq69UY44HCgfCIU60 vpCZVLWgHSIJeTPL5vuA3jHRDO60d95J2z+rsLGuy+wmGxzEw60n6UZLs4leLt3l 89UbHVP89Y0P6JA8FEPH1XeOumqS5cGlkRtxBeBKBoy0dgTKCA3jl3Ddd4zKGLKj JvKhncE= 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= LO8iMnG/B3v+lHqXcZS1CTTE51+lW/8zN1j9iTQEHTf1gTOpD5CM2HwyxRWKC7mK TqBiQr2SNLIt6txCdzZgSMpooiJOV8vXIGoSrGthfPhrs5H4FyFowjOJoUpLT8u7 FUwAWIXSVmrzghRq6vTtDWNpTT0Ozypihsy9uIW1Js8= 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 147C1C81F; Tue, 4 Jun 2013 10:44:53 -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 EAB11C81E; Tue, 4 Jun 2013 10:44:50 -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: 5081EE2C-CD25-11E2-9EA6-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:16462 Archived-At: * libguile/procprop.c (scm_i_procedure_arity): Allow RTL programs to dispatch to scm_i_program_arity. * libguile/programs.c (scm_i_program_print): Refactor reference to write-program. (scm_i_rtl_program_minimum_arity): New procedure, dispatches to Scheme. (scm_i_program_arity): Dispatch to scm_i_rtl_program_minimum_arity if appropriate. * module/system/vm/debug.scm (program-minimum-arity): New export. * module/system/vm/program.scm (rtl-program-minimum-arity): New internal function. (program-arguments-alists): New helper, implemented also for RTL procedures. (write-program): Refactor a bit, and call program-arguments-alists. * test-suite/tests/rtl.test ("simply procedure arity"): Add tests that arities make it all the way to cold ELF and back to warm Guile. --- libguile/procprop.c | 10 +------ libguile/programs.c | 30 ++++++++++++++++++--- module/system/vm/debug.scm | 3 ++- module/system/vm/program.scm | 59 ++++++++++++++++++++++++++++-------------- test-suite/tests/rtl.test | 30 +++++++++++++++++++++ 5 files changed, 99 insertions(+), 33 deletions(-) diff --git a/libguile/procprop.c b/libguile/procprop.c index 4809702..62476c0 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -60,7 +60,7 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest) return 1; } - while (!SCM_PROGRAM_P (proc)) + while (!SCM_PROGRAM_P (proc) && !SCM_RTL_PROGRAM_P (proc)) { if (SCM_STRUCTP (proc)) { @@ -82,14 +82,6 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest) return 1; } - else if (SCM_RTL_PROGRAM_P (proc)) - { - *req = 0; - *opt = 0; - *rest = 1; - - return 1; - } else return 0; } diff --git a/libguile/programs.c b/libguile/programs.c index d356915..12561b3 100644 --- a/libguile/programs.c +++ b/libguile/programs.c @@ -129,9 +129,8 @@ scm_i_program_print (SCM program, SCM port, scm_print_state *pstate) static int print_error = 0; if (scm_is_false (write_program) && scm_module_system_booted_p) - write_program = scm_module_local_variable - (scm_c_resolve_module ("system vm program"), - scm_from_latin1_symbol ("write-program")); + write_program = scm_c_private_variable ("system vm program", + "write-program"); if (SCM_PROGRAM_IS_CONTINUATION (program)) { @@ -450,11 +449,36 @@ parse_arity (SCM arity, int *req, int *opt, int *rest) *req = *opt = *rest = 0; } +static int +scm_i_rtl_program_minimum_arity (SCM program, int *req, int *opt, int *rest) +{ + static SCM rtl_program_minimum_arity = SCM_BOOL_F; + SCM l; + + if (scm_is_false (rtl_program_minimum_arity) && scm_module_system_booted_p) + rtl_program_minimum_arity = + scm_c_private_variable ("system vm debug", + "rtl-program-minimum-arity"); + + l = scm_call_1 (scm_variable_ref (rtl_program_minimum_arity), program); + if (scm_is_false (l)) + return 0; + + *req = scm_to_int (scm_car (l)); + *opt = scm_to_int (scm_cadr (l)); + *rest = scm_is_true (scm_caddr (l)); + + return 1; +} + int scm_i_program_arity (SCM program, int *req, int *opt, int *rest) { SCM arities; + if (SCM_RTL_PROGRAM_P (program)) + return scm_i_rtl_program_minimum_arity (program, req, opt, rest); + arities = scm_program_arities (program); if (!scm_is_pair (arities)) return 0; diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm index 724f2b4..81e2250 100644 --- a/module/system/vm/debug.scm +++ b/module/system/vm/debug.scm @@ -49,7 +49,8 @@ find-debug-context find-program-debug-info arity-arguments-alist - find-program-arities)) + find-program-arities + program-minimum-arity)) (define-record-type (make-debug-context elf base text-base) diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm index fdfc9a8..a4bd64e 100644 --- a/module/system/vm/program.scm +++ b/module/system/vm/program.scm @@ -61,6 +61,12 @@ (and=> (find-program-debug-info (rtl-program-code program)) program-debug-info-name)) +;; This procedure is called by programs.c. +(define (rtl-program-minimum-arity program) + (unless (rtl-program? program) + (error "shouldn't get here")) + (program-minimum-arity (rtl-program-code program))) + (define (make-binding name boxed? index start end) (list name boxed? index start end)) (define (binding:name b) (list-ref b 0)) @@ -276,25 +282,38 @@ 1+ 0))) +(define (program-arguments-alists prog) + (cond + ((rtl-program? prog) + (map arity-arguments-alist + (find-program-arities (rtl-program-code prog)))) + ((program? prog) + (map (lambda (arity) (arity->arguments-alist prog arity)) + (or (program-arities prog) '()))) + (else (error "expected a program" prog)))) + (define (write-program prog port) - (format port "#" - (or (procedure-name prog) - (and=> (and (program? prog) (program-source prog 0)) - (lambda (s) - (format #f "~a at ~a:~a:~a" - (number->string (object-address prog) 16) - (or (source:file s) - (if s "" "")) - (source:line-for-user s) (source:column s)))) - (number->string (object-address prog) 16)) - (let ((arities (and (program? prog) (program-arities prog)))) - (if (or (not arities) (null? arities)) - "" - (string-append - " " (string-join (map (lambda (a) - (object->string - (arguments-alist->lambda-list - (arity->arguments-alist prog a)))) - arities) - " | ")))))) + (define (program-identity-string) + (or (procedure-name prog) + (and=> (and (program? prog) (program-source prog 0)) + (lambda (s) + (format #f "~a at ~a:~a:~a" + (number->string (object-address prog) 16) + (or (source:file s) + (if s "" "")) + (source:line-for-user s) (source:column s)))) + (number->string (object-address prog) 16))) + (define (program-formals-string) + (let ((arguments (program-arguments-alists prog))) + (if (null? arguments) + "" + (string-append + " " (string-join (map (lambda (a) + (object->string + (arguments-alist->lambda-list a))) + arguments) + " | "))))) + + (format port "#" + (program-identity-string) (program-formals-string))) diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test index 1813969..c50aae9 100644 --- a/test-suite/tests/rtl.test +++ b/test-suite/tests/rtl.test @@ -316,3 +316,33 @@ (return 0) (end-arity) (end-program)))))) + +(with-test-prefix "simply procedure arity" + (pass-if-equal "#" + (object->string + (assemble-program + '((begin-program foo ((name . foo))) + (begin-standard-arity () 1 #f) + (load-constant 0 42) + (return 0) + (end-arity) + (end-program))))) + (pass-if-equal "#" + (object->string + (assemble-program + '((begin-program foo ((name . foo))) + (begin-standard-arity (x y) 2 #f) + (load-constant 0 42) + (return 0) + (end-arity) + (end-program))))) + + (pass-if-equal "#" + (object->string + (assemble-program + '((begin-program foo ((name . foo))) + (begin-opt-arity (x) (y) z 3 #f) + (load-constant 0 42) + (return 0) + (end-arity) + (end-program)))))) -- 1.7.10.4