summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/system/vm/debug.scm34
-rw-r--r--module/system/vm/frame.scm75
2 files changed, 73 insertions, 36 deletions
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index b4dfc3e16..6f2edc3a6 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -1,6 +1,6 @@
;;; Guile runtime debug information
-;;; Copyright (C) 2013 Free Software Foundation, Inc.
+;;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -55,6 +55,7 @@
arity-has-rest?
arity-allow-other-keys?
arity-has-keyword-args?
+ arity-keyword-args
arity-is-case-lambda?
debug-context-from-image
@@ -64,6 +65,7 @@
find-program-debug-info
arity-arguments-alist
find-program-arities
+ find-program-arity
find-program-minimum-arity
find-program-docstring
@@ -325,6 +327,25 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}."
(string->symbol (string-table-ref bv (+ strtab-offset n)))))))
(else (error "couldn't find arities section")))))
+(define (arity-keyword-args arity)
+ (let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
+ (header (arity-header-offset arity))
+ (link-offset (arity-offset* bv header))
+ (link (+ (arity-base arity) link-offset))
+ (flags (arity-flags* bv header))
+ (nreq (arity-nreq* bv header))
+ (nopt (arity-nopt* bv header)))
+ (define (unpack-scm n)
+ (pointer->scm (make-pointer n)))
+ (define (load-non-immediate idx)
+ (let ((offset (bytevector-u32-native-ref bv (+ link (* idx 4)))))
+ (unpack-scm (+ (debug-context-base (arity-context arity)) offset))))
+ (if (and (not (is-case-lambda? flags))
+ (has-keyword-args? flags))
+ (load-non-immediate
+ (+ nreq nopt (if (has-rest? flags) 1 0)))
+ '())))
+
(define (arity-arguments-alist arity)
(let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
(%load-symbol (arity-load-symbol arity))
@@ -405,6 +426,17 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}."
(read-sub-arities context base (arity-header-offset first)))
(else (list first)))))))
+(define* (find-program-arity addr #:optional
+ (context (find-debug-context addr)))
+ (let lp ((arities (or (find-program-arities addr context) '())))
+ (match arities
+ (() #f)
+ ((arity . arities)
+ (if (and (<= (arity-low-pc arity) addr)
+ (< addr (arity-high-pc arity)))
+ arity
+ (lp arities))))))
+
(define* (find-program-minimum-arity addr #:optional
(context (find-debug-context addr)))
(and=>
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index a5de861e4..a57307948 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -1,6 +1,6 @@
;;; Guile VM frame functions
-;;; Copyright (C) 2001, 2005, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2005, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -21,6 +21,7 @@
(define-module (system vm frame)
#:use-module (system base pmatch)
#:use-module (system vm program)
+ #:use-module (system vm debug)
#:export (frame-bindings
frame-lookup-binding
frame-binding-ref frame-binding-set!
@@ -83,49 +84,53 @@
;; stack, and nothing else is on the stack.
(define (frame-call-representation frame)
- (let ((p (frame-procedure frame)))
+ (let* ((ip (frame-instruction-pointer frame))
+ (info (find-program-debug-info ip))
+ (nlocals (frame-num-locals frame))
+ (closure (frame-procedure frame)))
+ (define (local-ref i)
+ (if (< i nlocals)
+ (frame-local-ref frame i)
+ ;; Let's not error here, as we are called during backtraces.
+ '???))
(cons
- (or (false-if-exception (procedure-name p)) p)
+ (or (and=> info program-debug-info-name)
+ (procedure-name closure)
+ (and info
+ ;; No need to give source info, as backtraces will already
+ ;; take care of that.
+ (format #f "#<procedure ~a>"
+ (number->string (program-debug-info-addr info) 16)))
+ (procedure-name closure)
+ closure)
(cond
- ((and (program? p)
- (program-arguments-alist p (frame-instruction-pointer frame)))
- ;; case 1
- => (lambda (arguments)
- (define (binding-ref sym i)
- (cond
- ((frame-lookup-binding frame sym)
- => (lambda (b) (frame-local-ref frame (binding:index b))))
- ((< i (frame-num-locals frame))
- (frame-local-ref frame i))
- (else
- ;; let's not error here, as we are called during backtraces...
- '???)))
- (let lp ((req (or (assq-ref arguments 'required) '()))
- (opt (or (assq-ref arguments 'optional) '()))
- (key (or (assq-ref arguments 'keyword) '()))
- (rest (or (assq-ref arguments 'rest) #f))
+ ((find-program-arity ip)
+ => (lambda (arity)
+ ;; case 1
+ (let lp ((nreq (arity-nreq arity))
+ (nopt (arity-nopt arity))
+ (kw (arity-keyword-args arity))
+ (has-rest? (arity-has-rest? arity))
(i 1))
(cond
- ((pair? req)
- (cons (binding-ref (car req) i)
- (lp (cdr req) opt key rest (1+ i))))
- ((pair? opt)
- (cons (binding-ref (car opt) i)
- (lp req (cdr opt) key rest (1+ i))))
- ((pair? key)
- (cons* (caar key)
- (frame-local-ref frame (cdar key))
- (lp req opt (cdr key) rest (1+ i))))
- (rest
- (binding-ref rest i))
+ ((positive? nreq)
+ (cons (local-ref i)
+ (lp (1- nreq) nopt kw has-rest? (1+ i))))
+ ((positive? nopt)
+ (cons (local-ref i)
+ (lp nreq (1- nopt) kw has-rest? (1+ i))))
+ ((pair? kw)
+ (cons* (caar kw) (local-ref (cdar kw))
+ (lp nreq nopt (cdr kw) has-rest? (1+ i))))
+ (has-rest?
+ (local-ref i))
(else
'())))))
(else
;; case 2
- (map (lambda (i)
- (frame-local-ref frame i))
+ (map local-ref
;; Cdr past the 0th local, which is the procedure.
- (cdr (iota (frame-num-locals frame)))))))))
+ (cdr (iota nlocals))))))))