mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-21 12:10:26 +02:00
Code Activity

Better backtraces for optimized closures

Browse source 
* module/system/vm/debug.scm (arity-keyword-args, find-program-arity):
  New exports.

* module/system/vm/frame.scm (frame-call-representation): Prefer to use
  the frame IP to get the procedure.
This commit is contained in:
Andy Wingo 2014-04-15 11:18:50 +02:00
parent da169db26a
commit bec786c1fe
2 changed files with 73 additions and 36 deletions
Download patch file Download diff file Expand all files Collapse all files

34
module/system/vm/debug.scm
View file

@ -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=>

75
module/system/vm/frame.scm
View file

@ -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))))))))