xref.scm 14 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373
  1. ;;;; Copyright (C) 2009, 2010, 2013, 2018 Free Software Foundation, Inc.
  2. ;;;;
  3. ;;;; This library is free software; you can redistribute it and/or
  4. ;;;; modify it under the terms of the GNU Lesser General Public
  5. ;;;; License as published by the Free Software Foundation; either
  6. ;;;; version 2.1 of the License, or (at your option) any later version.
  7. ;;;;
  8. ;;;; This library is distributed in the hope that it will be useful,
  9. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  11. ;;;; Lesser General Public License for more details.
  12. ;;;;
  13. ;;;; You should have received a copy of the GNU Lesser General Public
  14. ;;;; License along with this library; if not, write to the Free Software
  15. ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16. ;;;;
  17. (define-module (system xref)
  18. #:use-module (system vm program)
  19. #:use-module (system vm disassembler)
  20. #:use-module (ice-9 match)
  21. #:use-module (srfi srfi-1)
  22. #:export (*xref-ignored-modules*
  23. procedure-callees
  24. procedure-callers
  25. source-closures
  26. source-procedures))
  27. ;;;
  28. ;;; The cross-reference database: who calls whom.
  29. ;;;
  30. (define (nested-procedures prog)
  31. (define (cons-uniq x y)
  32. (if (memq x y) y (cons x y)))
  33. (if (program? prog)
  34. (reverse
  35. (fold-program-code (lambda (elt out)
  36. (match elt
  37. (('static-ref dst proc)
  38. (if (program? proc)
  39. (fold cons-uniq
  40. (cons proc out)
  41. (nested-procedures prog))
  42. out))
  43. (_ out)))
  44. (list prog)
  45. prog))
  46. (list prog)))
  47. (define (program-callee-rev-vars prog)
  48. (define (cons-uniq x y)
  49. (if (memq x y) y (cons x y)))
  50. (fold (lambda (prog out)
  51. (fold-program-code
  52. (lambda (elt out)
  53. ;; FIXME: Update for change to top-level variable
  54. ;; resolution. Need to build a per-program map of
  55. ;; IP->SLOT->CONSTANT to be able to resolve operands to
  56. ;; resolve-module and lookup intrinsic calls.
  57. (match elt
  58. (('toplevel-box dst var mod sym bound?)
  59. (let ((var (or var (and mod (module-variable mod sym)))))
  60. (if var
  61. (cons-uniq var out)
  62. out)))
  63. (('module-box dst var public? mod-name sym bound?)
  64. (let ((var (or var
  65. (module-variable (if public?
  66. (resolve-interface mod-name)
  67. (resolve-module mod-name))
  68. sym))))
  69. (if var
  70. (cons-uniq var out)
  71. out)))
  72. (_ out)))
  73. out
  74. prog))
  75. '()
  76. (nested-procedures prog)))
  77. (define (procedure-callee-rev-vars proc)
  78. (cond
  79. ((program? proc) (program-callee-rev-vars proc))
  80. (else '())))
  81. (define (procedure-callees prog)
  82. "Evaluates to a list of the given program callees."
  83. (let lp ((in (procedure-callee-rev-vars prog)) (out '()))
  84. (cond ((null? in) out)
  85. ((variable-bound? (car in))
  86. (lp (cdr in) (cons (variable-ref (car in)) out)))
  87. (else (lp (cdr in) out)))))
  88. ;; var -> ((module-name caller ...) ...)
  89. (define *callers-db* #f)
  90. ;; module-name -> (callee ...)
  91. (define *module-callees-db* (make-hash-table))
  92. ;; (module-name ...)
  93. (define *tainted-modules* '())
  94. (define *xref-ignored-modules* '((value-history)))
  95. (define (on-module-modified m)
  96. (let ((name (module-name m)))
  97. (if (and (not (member name *xref-ignored-modules*))
  98. (not (member name *tainted-modules*))
  99. (pair? name))
  100. (set! *tainted-modules* (cons name *tainted-modules*)))))
  101. (define (add-caller callee caller mod-name)
  102. (let ((all-callers (hashq-ref *callers-db* callee)))
  103. (if (not all-callers)
  104. (hashq-set! *callers-db* callee `((,mod-name ,caller)))
  105. (let ((callers (assoc mod-name all-callers)))
  106. (if callers
  107. (if (not (member caller callers))
  108. (set-cdr! callers (cons caller (cdr callers))))
  109. (hashq-set! *callers-db* callee
  110. (cons `(,mod-name ,caller) all-callers)))))))
  111. (define (forget-callers callee mod-name)
  112. (hashq-set! *callers-db* callee
  113. (assoc-remove! (hashq-ref *callers-db* callee '()) mod-name)))
  114. (define (add-callees callees mod-name)
  115. (hash-set! *module-callees-db* mod-name
  116. (append callees (hash-ref *module-callees-db* mod-name '()))))
  117. (define (untaint-modules)
  118. (define (untaint m)
  119. (for-each (lambda (callee) (forget-callers callee m))
  120. (hash-ref *module-callees-db* m '()))
  121. (ensure-callers-db m))
  122. (ensure-callers-db #f)
  123. (for-each untaint *tainted-modules*)
  124. (set! *tainted-modules* '()))
  125. (define (ensure-callers-db mod-name)
  126. (let ((mod (and mod-name (resolve-module mod-name)))
  127. (visited #f))
  128. (define (visit-variable var mod-name)
  129. (if (variable-bound? var)
  130. (let ((x (variable-ref var)))
  131. (cond
  132. ((and visited (hashq-ref visited x)))
  133. ((procedure? x)
  134. (if visited (hashq-set! visited x #t))
  135. (let ((callees (filter variable-bound?
  136. (procedure-callee-rev-vars x))))
  137. (for-each (lambda (callee)
  138. (add-caller callee x mod-name))
  139. callees)
  140. (add-callees callees mod-name)))))))
  141. (define (visit-module mod)
  142. (if visited (hashq-set! visited mod #t))
  143. (if (not (memq on-module-modified (module-observers mod)))
  144. (module-observe mod on-module-modified))
  145. (let ((name (module-name mod)))
  146. (module-for-each (lambda (sym var)
  147. (visit-variable var name))
  148. mod)))
  149. (define (visit-submodules mod)
  150. (hash-for-each
  151. (lambda (name sub)
  152. (if (not (and visited (hashq-ref visited sub)))
  153. (begin
  154. (visit-module sub)
  155. (visit-submodules sub))))
  156. (module-submodules mod)))
  157. (cond ((and (not mod-name) (not *callers-db*))
  158. (set! *callers-db* (make-hash-table 1000))
  159. (set! visited (make-hash-table 1000))
  160. (visit-submodules (resolve-module '() #f)))
  161. (mod-name (visit-module mod)))))
  162. (define (procedure-callers var)
  163. "Returns an association list, keyed by module name, of known callers
  164. of the given procedure. The latter can specified directly as a
  165. variable, a symbol (which gets resolved in the current module) or a
  166. pair of the form (module-name . variable-name), "
  167. (let ((v (cond ((variable? var) var)
  168. ((symbol? var) (module-variable (current-module) var))
  169. (else
  170. (match var
  171. ((modname . sym)
  172. (module-variable (resolve-module modname) sym))
  173. (_
  174. (error "expected a variable, symbol, or (modname . sym)" var)))))))
  175. (untaint-modules)
  176. (hashq-ref *callers-db* v '())))
  177. ;;;
  178. ;;; The source database: procedures defined at a given source location.
  179. ;;;
  180. ;; FIXME: refactor to share code with the xref database.
  181. ;; ((ip file line . col) ...)
  182. (define (procedure-sources proc)
  183. (cond
  184. ((program? proc) (program-sources proc))
  185. (else '())))
  186. ;; file -> line -> (proc ...)
  187. (define *closure-sources-db* #f)
  188. ;; file -> line -> (proc ...)
  189. (define *sources-db* #f)
  190. ;; module-name -> proc -> sources
  191. (define *module-sources-db* (make-hash-table))
  192. ;; (module-name ...)
  193. (define *tainted-sources* '())
  194. (define (on-source-modified m)
  195. (let ((name (module-name m)))
  196. (if (and (not (member name *xref-ignored-modules*))
  197. (not (member name *tainted-sources*))
  198. (pair? name))
  199. (set! *tainted-sources* (cons name *tainted-sources*)))))
  200. (define (add-source proc file line db)
  201. (let ((file-table (or (hash-ref db file)
  202. (let ((table (make-hash-table)))
  203. (hash-set! db file table)
  204. table))))
  205. (hashv-set! file-table
  206. line
  207. (cons proc (hashv-ref file-table line '())))))
  208. (define (forget-source proc file line db)
  209. (let ((file-table (hash-ref db file)))
  210. (if file-table
  211. (let ((procs (delq proc (hashv-ref file-table line '()))))
  212. (if (pair? procs)
  213. (hashv-set! file-table line procs)
  214. (hashv-remove! file-table line))))))
  215. (define (add-sources proc mod-name db)
  216. (let ((sources (procedure-sources proc)))
  217. (if (pair? sources)
  218. (begin
  219. ;; Add proc to *module-sources-db*, for book-keeping.
  220. (hashq-set! (or (hash-ref *module-sources-db* mod-name)
  221. (let ((table (make-hash-table)))
  222. (hash-set! *module-sources-db* mod-name table)
  223. table))
  224. proc
  225. sources)
  226. ;; Actually add the source entries.
  227. (for-each (lambda (source)
  228. (match source
  229. ((ip file line . col)
  230. (add-source proc file line db))
  231. (_ (error "unexpected source format" source))))
  232. sources)))
  233. ;; Add source entries for nested procedures.
  234. (for-each (lambda (obj)
  235. (add-sources obj mod-name *closure-sources-db*))
  236. (cdr (nested-procedures proc)))))
  237. (define (forget-sources proc mod-name db)
  238. (let ((mod-table (hash-ref *module-sources-db* mod-name)))
  239. (when mod-table
  240. ;; Forget source entries.
  241. (for-each (lambda (source)
  242. (match source
  243. ((ip file line . col)
  244. (forget-source proc file line db))
  245. (_ (error "unexpected source format" source))))
  246. (hashq-ref mod-table proc '()))
  247. ;; Forget the proc.
  248. (hashq-remove! mod-table proc)
  249. ;; Forget source entries for nested procedures.
  250. (for-each (lambda (obj)
  251. (forget-sources obj mod-name *closure-sources-db*))
  252. (cdr (nested-procedures proc))))))
  253. (define (untaint-sources)
  254. (define (untaint m)
  255. (for-each (lambda (proc) (forget-sources proc m *sources-db*))
  256. (cond
  257. ((hash-ref *module-sources-db* m)
  258. => (lambda (table)
  259. (hash-for-each (lambda (proc sources) proc) table)))
  260. (else '())))
  261. (ensure-sources-db m))
  262. (ensure-sources-db #f)
  263. (for-each untaint *tainted-sources*)
  264. (set! *tainted-sources* '()))
  265. (define (ensure-sources-db mod-name)
  266. (define (visit-module mod)
  267. (if (not (memq on-source-modified (module-observers mod)))
  268. (module-observe mod on-source-modified))
  269. (let ((name (module-name mod)))
  270. (module-for-each
  271. (lambda (sym var)
  272. (if (variable-bound? var)
  273. (let ((x (variable-ref var)))
  274. (if (procedure? x)
  275. (add-sources x name *sources-db*)))))
  276. mod)))
  277. (define visit-submodules
  278. (let ((visited #f))
  279. (lambda (mod)
  280. (if (not visited)
  281. (set! visited (make-hash-table)))
  282. (hash-for-each
  283. (lambda (name sub)
  284. (if (not (hashq-ref visited sub))
  285. (begin
  286. (hashq-set! visited sub #t)
  287. (visit-module sub)
  288. (visit-submodules sub))))
  289. (module-submodules mod)))))
  290. (cond ((and (not mod-name) (not *sources-db*) (not *closure-sources-db*))
  291. (set! *closure-sources-db* (make-hash-table 1000))
  292. (set! *sources-db* (make-hash-table 1000))
  293. (visit-submodules (resolve-module '() #f)))
  294. (mod-name (visit-module (resolve-module mod-name)))))
  295. (define (lines->ranges file-table)
  296. (let ((ranges (make-hash-table)))
  297. (hash-for-each
  298. (lambda (line procs)
  299. (for-each
  300. (lambda (proc)
  301. (cond
  302. ((hashq-ref ranges proc)
  303. => (lambda (pair)
  304. (if (< line (car pair))
  305. (set-car! pair line))
  306. (if (> line (cdr pair))
  307. (set-cdr! pair line))))
  308. (else
  309. (hashq-set! ranges proc (cons line line)))))
  310. procs))
  311. file-table)
  312. (sort! (hash-map->list cons ranges)
  313. (lambda (x y) (< (cadr x) (cadr y))))))
  314. (define* (lookup-source-procedures canon-file line db)
  315. (let ((file-table (hash-ref db canon-file)))
  316. (let lp ((ranges (if file-table (lines->ranges file-table) '()))
  317. (procs '()))
  318. (cond
  319. ((null? ranges) (reverse procs))
  320. ((<= (cadar ranges) line (cddar ranges))
  321. (lp (cdr ranges) (cons (caar ranges) procs)))
  322. (else
  323. (lp (cdr ranges) procs))))))
  324. (define* (source-closures file line #:key (canonicalization 'relative))
  325. (ensure-sources-db #f)
  326. (let* ((port (with-fluids ((%file-port-name-canonicalization canonicalization))
  327. (false-if-exception (open-input-file file))))
  328. (file (if port (port-filename port) file)))
  329. (lookup-source-procedures file line *closure-sources-db*)))
  330. (define* (source-procedures file line #:key (canonicalization 'relative))
  331. (ensure-sources-db #f)
  332. (let* ((port (with-fluids ((%file-port-name-canonicalization canonicalization))
  333. (false-if-exception (open-input-file file))))
  334. (file (if port (port-filename port) file)))
  335. (lookup-source-procedures file line *sources-db*)))