diff options
author | Andy Wingo <wingo@pobox.com> | 2014-04-15 11:18:50 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2014-04-15 11:18:50 +0200 |
commit | bec786c1fecd79c37d82cf263eef8e49bb1bf717 (patch) | |
tree | e44ea08de71e215df9018afa19df5c4cea827636 | |
parent | da169db26ae3ac4c2440b1fcb678cfd18392c5aa (diff) | |
download | guile-bec786c1fecd79c37d82cf263eef8e49bb1bf717.tar.gz |
Better backtraces for optimized closures
* 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.
-rw-r--r-- | module/system/vm/debug.scm | 34 | ||||
-rw-r--r-- | module/system/vm/frame.scm | 75 |
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)))))))) |