summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-05-16 20:58:54 +0200
committerAndy Wingo <wingo@pobox.com>2013-06-09 23:43:25 +0200
commiteb2bc00fb3863986927f0bade97487209b6d6a5b (patch)
tree8671c68378b99fc3066de39d6e0e9dc1e11a8b3e /module
parentf88e574d58aa3e64b6f1ed0bc6ea918d20a67d88 (diff)
downloadguile-eb2bc00fb3863986927f0bade97487209b6d6a5b.tar.gz
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.
Diffstat (limited to 'module')
-rw-r--r--module/system/vm/debug.scm3
-rw-r--r--module/system/vm/program.scm59
2 files changed, 41 insertions, 21 deletions
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 (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 "#<procedure ~a~a>"
- (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 "<current input>" "<unknown port>"))
- (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 "<current input>" "<unknown port>"))
+ (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 "#<procedure ~a~a>"
+ (program-identity-string) (program-formals-string)))