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

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