extra/tools/image-analyzer/references/references.factor

   1 ! Tools to follow references in the loaded image.
   2 USING: accessors byte-arrays fry kernel layouts math math.bitwise
   3 sequences slots.syntax tools.image-analyzer.relocations ;
   4 IN: tools.image-analyzer.references
   5 QUALIFIED-WITH: tools.image-analyzer.vm vm
   6
   7 ! Edges in the heap
   8 GENERIC: pointers ( heap heap-node struct -- seq )
   9
  10 M: vm:array pointers ( heap heap-node struct -- seq )
  11     drop nip payload>> ;
  12
  13 : find-heap-node ( heap ptr -- node )
  14     15 unmask '[ address>> _ = ] find nip ;
  15
  16 : load-relocations ( heap code-block -- seq )
  17     relocation>> find-heap-node payload>> >byte-array byte-array>relocations
  18     [ first 2 = ] filter ;
  19
  20 : relocation>pointer ( heap-node relocation -- ptr )
  21     over payload>> swap load-relative-value swap address>> + ;
  22
  23 : relocation-pointers ( heap heap-node code-block -- seq )
  24     swapd load-relocations [ relocation>pointer ] with map ;
  25
  26 M: vm:code-block pointers ( heap heap-node struct -- seq )
  27     [ relocation-pointers ] [ slots{ owner parameters relocation } ] bi
  28     append ;
  29
  30 M: vm:word pointers ( heap heap-node struct -- seq )
  31     2nip [
  32         slots{ def name props vocabulary }
  33     ] [ entry_point>> 4 cell * - ] bi suffix ;
  34
  35 M: object pointers ( heap heap-node struct -- seq )
  36     3drop { } ;
  37
  38 : collect-pointers ( heap heap-node -- seq )
  39     dup object>> pointers [ 1 <= ] reject [ 15 unmask ] map ;