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-image
program-debug-info-offset
program-debug-info-size
program-debug-info-addr
program-debug-info-u32-offset
program-debug-info-u32-offset-end

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

@ -57,9 +57,9 @@
(define-module (system vm traps)
#:use-module (system base pmatch)
#:use-module (system vm vm)
#:use-module (system vm debug)
#:use-module (system vm frame)
#:use-module (system vm program)
#:use-module (system vm objcode)
#:use-module (system vm instruction)
#:use-module (system xref)
#:use-module (rnrs bytevectors)
@ -108,24 +108,20 @@
(define (new-enabled-trap vm frame enable disable)
((new-disabled-trap vm enable disable) frame))
(define (frame-matcher proc match-objcode?)
(if match-objcode?
(cond
((program? proc)
(lambda (frame)
(let ((frame-proc (frame-procedure frame)))
(or (eq? frame-proc proc)
(and (program? frame-proc)
(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)))
;; Returns an absolute IP.
(define (program-last-ip prog)
(let ((pdi (find-program-debug-info (rtl-program-code prog))))
(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)
(let ((ip (frame-instruction-pointer frame)))
(and (<= start ip) (< ip end)))))
(lambda (frame) #f))
(lambda (frame)
(eq? (frame-procedure frame) proc))))
@ -319,41 +315,41 @@
#:current-frame current-frame #:vm vm
#: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)
(let lp ((sources (program-sources-pre-retire proc))
(out '()))
(if (pair? sources)
(lp (cdr sources)
(pmatch (car sources)
((,start-ip ,start-file ,start-line . ,start-col)
(if (equal? start-file file)
(cons (cons start-line
(if (pair? (cdr sources))
(pmatch (cadr sources)
((,end-ip . _)
(cons start-ip end-ip))
(else (error "unexpected")))
(cons start-ip (program-last-ip proc))))
out)
out))
(else (error "unexpected"))))
(let ((alist '()))
(for-each
(lambda (pair)
(set! alist
(assv-set! alist (car pair)
(cons (cdr pair)
(or (assv-ref alist (car pair))
'())))))
out)
(sort! alist (lambda (x y) (< (car x) (car y))))
alist))))
(cond
((rtl-program? proc)
(let ((code (rtl-program-code proc)))
(let lp ((sources (program-sources proc))
(out '()))
(if (pair? sources)
(lp (cdr sources)
(pmatch (car sources)
((,start-ip ,start-file ,start-line . ,start-col)
(if (equal? start-file file)
(acons start-line
(if (pair? (cdr sources))
(pmatch (cadr sources)
((,end-ip . _)
(cons (+ start-ip code)
(+ end-ip code)))
(else (error "unexpected")))
(cons (+ start-ip code)
(program-last-ip proc)))
out)
out))
(else (error "unexpected"))))
(let ((alist '()))
(for-each
(lambda (pair)
(set! alist
(assv-set! alist (car pair)
(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)
(or (or-map (lambda (line-and-ranges)