From eb2bc00fb3863986927f0bade97487209b6d6a5b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 16 May 2013 20:58:54 +0200 Subject: [PATCH] Wire up ability to print RTL program arities * 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 | 61 +++++++++++++++++++++++------------- test-suite/tests/rtl.test | 30 ++++++++++++++++++ 5 files changed, 100 insertions(+), 34 deletions(-) diff --git a/libguile/procprop.c b/libguile/procprop.c index 480970266..62476c037 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)) { @@ -80,14 +80,6 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest) see. */ *req -= 1; - return 1; - } - else if (SCM_RTL_PROGRAM_P (proc)) - { - *req = 0; - *opt = 0; - *rest = 1; - return 1; } else diff --git a/libguile/programs.c b/libguile/programs.c index d3569159a..12561b30d 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 6f241087d..5196ecae1 100644 --- a/module/system/vm/debug.scm +++ b/module/system/vm/debug.scm @@ -55,7 +55,8 @@ find-debug-context find-program-debug-info arity-arguments-alist - find-program-arities)) + find-program-arities + program-minimum-arity)) ;;; A compiled procedure comes from a specific loaded ELF image. A ;;; debug context identifies that image. diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm index fdfc9a8aa..a4bd64e28 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 (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-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) + (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 18139697f..c50aae966 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))))))