xref.scm 14 KB

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