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

(system vm traps) support for rtl programs

Browse source 
* module/system/vm/debug.scm: Export program-debug-info-size.

* module/system/vm/traps.scm (frame-matcher): Remove stack program
  case.  Use absolute frame-instruction-procedure to match if
  match-code?.
  (program-last-ip): Use (system vm debug) interfaces.
  (program-sources-by-line): Use program-sources, as
  program-sources-pre-retire will go away soon.  Return absolute
  addresses.
This commit is contained in:
Andy Wingo 2013-11-08 17:31:51 +01:00
parent 0d4bcc71d2
commit e391f179e4
2 changed files with 50 additions and 53 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -42,6 +42,7 @@
program-debug-info-context program-debug-info-context
program-debug-info-image program-debug-info-image
program-debug-info-offset program-debug-info-offset
program-debug-info-size
program-debug-info-addr program-debug-info-addr
program-debug-info-u32-offset program-debug-info-u32-offset
program-debug-info-u32-offset-end program-debug-info-u32-offset-end

102
module/system/vm/traps.scm
View file

@ -57,9 +57,9 @@
(define-module (system vm traps) (define-module (system vm traps)
#:use-module (system base pmatch) #:use-module (system base pmatch)
#:use-module (system vm vm) #:use-module (system vm vm)
#:use-module (system vm debug)
#:use-module (system vm frame) #:use-module (system vm frame)
#:use-module (system vm program) #:use-module (system vm program)
#:use-module (system vm objcode)
#:use-module (system vm instruction) #:use-module (system vm instruction)
#:use-module (system xref) #:use-module (system xref)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
@ -108,24 +108,20 @@
(define (new-enabled-trap vm frame enable disable) (define (new-enabled-trap vm frame enable disable)
((new-disabled-trap vm enable disable) frame)) ((new-disabled-trap vm enable disable) frame))
(define (frame-matcher proc match-objcode?) ;; Returns an absolute IP.
(if match-objcode? (define (program-last-ip prog)
(cond (let ((pdi (find-program-debug-info (rtl-program-code prog))))
((program? proc) (and pdi (program-debug-info-size pdi))))
(lambda (frame)
(let ((frame-proc (frame-procedure frame))) (define (frame-matcher proc match-code?)
(or (eq? frame-proc proc) (if match-code?
(and (program? frame-proc) (if (rtl-program? proc)
(eq? (program-objcode frame-proc) (let ((start (rtl-program-code proc))
(program-objcode proc))))))) (end (program-last-ip proc)))
((rtl-program? proc) (lambda (frame)
(lambda (frame) (let ((ip (frame-instruction-pointer frame)))
(let ((frame-proc (frame-procedure frame))) (and (<= start ip) (< ip end)))))
(or (eq? frame-proc proc) (lambda (frame) #f))
(and (rtl-program? frame-proc)
(eqv? (rtl-program-code frame-proc)
(rtl-program-code proc)))))))
(else (lambda (frame) #f)))
(lambda (frame) (lambda (frame)
(eq? (frame-procedure frame) proc)))) (eq? (frame-procedure frame) proc))))
@ -319,41 +315,41 @@
#:current-frame current-frame #:vm vm #:current-frame current-frame #:vm vm
#:our-frame? our-frame?))) #:our-frame? our-frame?)))
;; FIXME: define this in objcode somehow. We are reffing the first
;; uint32 in the objcode, which is the length of the program (without
;; the meta).
(define (program-last-ip prog)
(bytevector-u32-native-ref (objcode->bytecode (program-objcode prog)) 0))
(define (program-sources-by-line proc file) (define (program-sources-by-line proc file)
(let lp ((sources (program-sources-pre-retire proc)) (cond
(out '())) ((rtl-program? proc)
(if (pair? sources) (let ((code (rtl-program-code proc)))
(lp (cdr sources) (let lp ((sources (program-sources proc))
(pmatch (car sources) (out '()))
((,start-ip ,start-file ,start-line . ,start-col) (if (pair? sources)
(if (equal? start-file file) (lp (cdr sources)
(cons (cons start-line (pmatch (car sources)
(if (pair? (cdr sources)) ((,start-ip ,start-file ,start-line . ,start-col)
(pmatch (cadr sources) (if (equal? start-file file)
((,end-ip . _) (acons start-line
(cons start-ip end-ip)) (if (pair? (cdr sources))
(else (error "unexpected"))) (pmatch (cadr sources)
(cons start-ip (program-last-ip proc)))) ((,end-ip . _)
out) (cons (+ start-ip code)
out)) (+ end-ip code)))
(else (error "unexpected")))) (else (error "unexpected")))
(let ((alist '())) (cons (+ start-ip code)
(for-each (program-last-ip proc)))
(lambda (pair) out)
(set! alist out))
(assv-set! alist (car pair) (else (error "unexpected"))))
(cons (cdr pair) (let ((alist '()))
(or (assv-ref alist (car pair)) (for-each
'()))))) (lambda (pair)
out) (set! alist
(sort! alist (lambda (x y) (< (car x) (car y)))) (assv-set! alist (car pair)
alist)))) (cons (cdr pair)
(or (assv-ref alist (car pair))
'())))))
out)
(sort! alist (lambda (x y) (< (car x) (car y))))
alist)))))
(else '())))
(define (source->ip-range proc file line) (define (source->ip-range proc file line)
(or (or-map (lambda (line-and-ranges) (or (or-map (lambda (line-and-ranges)