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

Rewrite (system xref) to work with RTL programs

Browse source 
* module/system/xref.scm (nested-procedures): New helper.
  (program-callee-rev-vars): Rewrite using fold-program-code and
  nested-procedures.
  (add-sources, forget-sources): Use match instead of pmatch.  Use
  nested-procedures.
This commit is contained in:
Andy Wingo 2013-11-08 16:31:29 +01:00
parent 850e80dacc
commit 147f9978ba
1 changed files with 66 additions and 77 deletions
Download patch file Download diff file Expand all files Collapse all files

143
module/system/xref.scm
View file

@ -17,9 +17,10 @@
(define-module (system xref) (define-module (system xref)
#:use-module (system base pmatch)
#:use-module (system base compile) #:use-module (system base compile)
#:use-module (system vm program) #:use-module (system vm program)
#:use-module (system vm disassembler)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:export (*xref-ignored-modules* #:export (*xref-ignored-modules*
procedure-callees procedure-callees
@ -31,59 +32,54 @@
;;; The cross-reference database: who calls whom. ;;; The cross-reference database: who calls whom.
;;; ;;;
(define (nested-procedures prog)
(define (cons-uniq x y)
(if (memq x y) y (cons x y)))
(if (rtl-program? prog)
(reverse
(fold-program-code (lambda (elt out)
(match elt
(('static-ref dst proc)
(if (rtl-program? proc)
(fold cons-uniq
(cons proc out)
(nested-procedures prog))
out))
(_ out)))
(list prog)
prog))
(list prog)))
(define (program-callee-rev-vars prog) (define (program-callee-rev-vars prog)
(define (cons-uniq x y) (define (cons-uniq x y)
(if (memq x y) y (cons x y))) (if (memq x y) y (cons x y)))
(cond (fold (lambda (prog out)
((program-objects prog) (fold-program-code
=> (lambda (objects) (lambda (elt out)
(let ((n (vector-length objects)) (match elt
(progv (make-vector (vector-length objects) #f)) (('toplevel-box dst var mod sym bound?)
(asm (decompile (program-objcode prog) #:to 'assembly))) (let ((var (or var (and mod (module-variable mod sym)))))
(pmatch asm (if var
((load-program ,labels ,len . ,body) (cons-uniq var out)
(for-each out)))
(lambda (x) (('module-box dst var public? mod-name sym bound?)
(pmatch x (let ((var (or var
((toplevel-ref ,n) (vector-set! progv n #t)) (module-variable (if public?
((toplevel-set ,n) (vector-set! progv n #t)))) (resolve-interface mod-name)
body))) (resolve-module mod-name))
(let lp ((i 0) (out '())) sym))))
(cond (if var
((= i n) out) (cons-uniq var out)
((program? (vector-ref objects i)) out)))
(lp (1+ i) (_ out)))
(fold cons-uniq out out
(program-callee-rev-vars (vector-ref objects i))))) prog))
((vector-ref progv i) '()
(let ((obj (vector-ref objects i))) (nested-procedures prog)))
(if (variable? obj)
(lp (1+ i) (cons-uniq obj out))
;; otherwise it's an unmemoized binding
(pmatch obj
(,sym (guard (symbol? sym))
(let ((v (module-variable (or (program-module prog)
the-root-module)
sym)))
(lp (1+ i) (if v (cons-uniq v out) out))))
((,mod ,sym ,public?)
;; hm, hacky.
(let* ((m (nested-ref-module (resolve-module '() #f)
mod))
(v (and m
(module-variable
(if public?
(module-public-interface m)
m)
sym))))
(lp (1+ i)
(if v (cons-uniq v out) out))))))))
(else (lp (1+ i) out)))))))
(else '())))
(define (procedure-callee-rev-vars proc) (define (procedure-callee-rev-vars proc)
(cond (cond
((program? proc) (program-callee-rev-vars proc)) ((rtl-program? proc) (program-callee-rev-vars proc))
(else '()))) (else '())))
(define (procedure-callees prog) (define (procedure-callees prog)
@ -186,10 +182,10 @@ pair of the form (module-name . variable-name), "
(let ((v (cond ((variable? var) var) (let ((v (cond ((variable? var) var)
((symbol? var) (module-variable (current-module) var)) ((symbol? var) (module-variable (current-module) var))
(else (else
(pmatch var (match var
((,modname . ,sym) ((modname . sym)
(module-variable (resolve-module modname) sym)) (module-variable (resolve-module modname) sym))
(else (_
(error "expected a variable, symbol, or (modname . sym)" var))))))) (error "expected a variable, symbol, or (modname . sym)" var)))))))
(untaint-modules) (untaint-modules)
(hashq-ref *callers-db* v '()))) (hashq-ref *callers-db* v '())))
@ -255,39 +251,32 @@ pair of the form (module-name . variable-name), "
sources) sources)
;; Actually add the source entries. ;; Actually add the source entries.
(for-each (lambda (source) (for-each (lambda (source)
(pmatch source (match source
((,ip ,file ,line . ,col) ((ip file line . col)
(add-source proc file line db)) (add-source proc file line db))
(else (error "unexpected source format" source)))) (_ (error "unexpected source format" source))))
sources))) sources)))
;; Add source entries for nested procedures. ;; Add source entries for nested procedures.
(for-each (lambda (obj) (for-each (lambda (obj)
(if (procedure? obj) (add-sources obj mod-name *closure-sources-db*))
(add-sources obj mod-name *closure-sources-db*))) (cdr (nested-procedures proc)))))
(or (and (program? proc)
(and=> (program-objects proc) vector->list))
'()))))
(define (forget-sources proc mod-name db) (define (forget-sources proc mod-name db)
(let ((mod-table (hash-ref *module-sources-db* mod-name))) (let ((mod-table (hash-ref *module-sources-db* mod-name)))
(if mod-table (when mod-table
(begin ;; Forget source entries.
;; Forget source entries. (for-each (lambda (source)
(for-each (lambda (source) (match source
(pmatch source ((ip file line . col)
((,ip ,file ,line . ,col) (forget-source proc file line db))
(forget-source proc file line db)) (_ (error "unexpected source format" source))))
(else (error "unexpected source format" source)))) (hashq-ref mod-table proc '()))
(hashq-ref mod-table proc '())) ;; Forget the proc.
;; Forget the proc. (hashq-remove! mod-table proc)
(hashq-remove! mod-table proc) ;; Forget source entries for nested procedures.
;; Forget source entries for nested procedures. (for-each (lambda (obj)
(for-each (lambda (obj) (forget-sources obj mod-name *closure-sources-db*))
(if (procedure? obj) (cdr (nested-procedures proc))))))
(forget-sources obj mod-name *closure-sources-db*)))
(or (and (program? proc)
(and=> (program-objects proc) vector->list))
'()))))))
(define (untaint-sources) (define (untaint-sources)
(define (untaint m) (define (untaint m)