1 ! Copyright (C) 2013 Björn Lindqvist
2 ! See http://factorcode.org/license.txt for BSD license
4 ! Tools to follow references in the loaded image.
5 USING: accessors arrays byte-arrays fry kernel layouts math
6 math.bitwise math.order sequences sets slots.syntax
7 tools.image-analyzer.relocations ;
8 IN: tools.image-analyzer.references
9 QUALIFIED-WITH: tools.image-analyzer.vm vm
12 GENERIC: pointers ( heap heap-node struct -- seq )
14 : find-heap-node ( heap ptr -- node )
15 15 unmask '[ address>> _ = ] find nip ;
17 : load-relocations ( heap code-block -- seq )
18 relocation>> find-heap-node payload>> >byte-array byte-array>relocations
19 [ interesting-relocation? ] filter ;
21 : relocation>pointer ( heap-node relocation -- ptr )
22 [ [ address>> ] [ payload>> ] bi ] dip decode-relocation ;
24 : relocation-pointers ( heap heap-node code-block -- seq )
25 swapd load-relocations [ relocation>pointer ] with map ;
27 : filter-data-pointers ( seq -- seq' )
28 [ 15 mask 1 <= ] reject ;
30 M: vm:array pointers ( heap heap-node struct -- seq )
31 drop nip payload>> filter-data-pointers ;
33 M: vm:code-block pointers ( heap heap-node struct -- seq )
34 [ relocation-pointers ] [ slots{ owner parameters relocation } ] bi
37 M: vm:quotation pointers ( heap heap-node struct -- seq )
38 2nip [ array>> ] [ entry_point>> 4 cell * - ] bi 2array ;
40 M: vm:word pointers ( heap heap-node struct -- seq )
42 slots{ def name pic_def pic_tail_def props subprimitive vocabulary }
44 ] [ entry_point>> 4 cell * - ] bi suffix ;
46 M: object pointers ( heap heap-node struct -- seq )
49 : collect-pointers ( heap heap-node -- seq )
50 dup object>> pointers [ 1 <= ] reject [ 15 unmask ] map ;