mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-07-05 17:20: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

54
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))))
(define (frame-matcher proc match-code?)
(if match-code?
(if (rtl-program? proc)
(let ((start (rtl-program-code proc))
(end (program-last-ip proc)))
(lambda (frame) (lambda (frame)
(let ((frame-proc (frame-procedure frame))) (let ((ip (frame-instruction-pointer frame)))
(or (eq? frame-proc proc) (and (<= start ip) (< ip end)))))
(and (program? frame-proc) (lambda (frame) #f))
(eq? (program-objcode frame-proc)
(program-objcode proc)))))))
((rtl-program? proc)
(lambda (frame)
(let ((frame-proc (frame-procedure frame)))
(or (eq? frame-proc proc)
(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,27 +315,26 @@
#: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
((rtl-program? proc)
(let ((code (rtl-program-code proc)))
(let lp ((sources (program-sources proc))
(out '())) (out '()))
(if (pair? sources) (if (pair? sources)
(lp (cdr sources) (lp (cdr sources)
(pmatch (car sources) (pmatch (car sources)
((,start-ip ,start-file ,start-line . ,start-col) ((,start-ip ,start-file ,start-line . ,start-col)
(if (equal? start-file file) (if (equal? start-file file)
(cons (cons start-line (acons start-line
(if (pair? (cdr sources)) (if (pair? (cdr sources))
(pmatch (cadr sources) (pmatch (cadr sources)
((,end-ip . _) ((,end-ip . _)
(cons start-ip end-ip)) (cons (+ start-ip code)
(+ end-ip code)))
(else (error "unexpected"))) (else (error "unexpected")))
(cons start-ip (program-last-ip proc)))) (cons (+ start-ip code)
(program-last-ip proc)))
out) out)
out)) out))
(else (error "unexpected")))) (else (error "unexpected"))))
@ -353,7 +348,8 @@
'()))))) '())))))
out) out)
(sort! alist (lambda (x y) (< (car x) (car y)))) (sort! alist (lambda (x y) (< (car x) (car y))))
alist)))) 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)