tools.image-analyzer: now also loads absolute relocation pointers

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

@@ -2,11 +2,11 @@ USING: accessors bootstrap.image fry grouping io.files io.pathnames kernel
 sequences system tools.deploy.backend tools.image-analyzer tools.test ;
 IN: tools.image-analyzer.tests
 
-: image-path ( arch -- path )
+: boot-image-path ( arch -- path )
     boot-image-name resource-path ;
 
 : ?make-image ( arch -- )
-    dup image-path exists? [ drop ] [ make-image ] if ;
+    dup boot-image-path exists? [ drop ] [ make-image ] if ;
 
 : loadable-images ( -- images )
     image-names cpu name>> '[ _ tail? ] filter ;
@@ -14,7 +14,7 @@ IN: tools.image-analyzer.tests
 { t } [
     loadable-images [ [ ?make-image ] each ] [
         [
-            image-path load-image drop code-size>>
+            boot-image-path load-image header>> code-size>>
         ] map [ 0 = ] all?
     ] bi
 ] unit-test

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

@@ -1,35 +1,46 @@
+! Copyright (C) 2013 Björn Lindqvist
+! See http://factorcode.org/license.txt for BSD license
+!
 ! Tools to follow references in the loaded image.
-USING: accessors byte-arrays fry kernel layouts math math.bitwise
+USING: accessors arrays byte-arrays fry kernel layouts math
-sequences slots.syntax tools.image-analyzer.relocations ;
+math.bitwise math.order sequences sets slots.syntax
+tools.image-analyzer.relocations ;
 IN: tools.image-analyzer.references
 QUALIFIED-WITH: tools.image-analyzer.vm vm
 
 ! Edges in the heap
 GENERIC: pointers ( heap heap-node struct -- seq )
 
-M: vm:array pointers ( heap heap-node struct -- seq )
-    drop nip payload>> ;
-
 : find-heap-node ( heap ptr -- node )
     15 unmask '[ address>> _ = ] find nip ;
 
 : load-relocations ( heap code-block -- seq )
     relocation>> find-heap-node payload>> >byte-array byte-array>relocations
-    [ first 2 = ] filter ;
+    [ interesting-relocation? ] filter ;
 
 : relocation>pointer ( heap-node relocation -- ptr )
-    over payload>> swap load-relative-value swap address>> + ;
+    [ [ address>> ] [ payload>> ] bi ] dip decode-relocation ;
 
 : relocation-pointers ( heap heap-node code-block -- seq )
     swapd load-relocations [ relocation>pointer ] with map ;
 
+: filter-data-pointers ( seq -- seq' )
+    [ 15 mask 1 <= ] reject ;
+
+M: vm:array pointers ( heap heap-node struct -- seq )
+    drop nip payload>> filter-data-pointers ;
+
 M: vm:code-block pointers ( heap heap-node struct -- seq )
     [ relocation-pointers ] [ slots{ owner parameters relocation } ] bi
     append ;
 
+M: vm:quotation pointers ( heap heap-node struct -- seq )
+    2nip [ array>> ] [ entry_point>> 4 cell * - ] bi 2array ;
+
 M: vm:word pointers ( heap heap-node struct -- seq )
     2nip [
-        slots{ def name props vocabulary }
+        slots{ def name pic_def pic_tail_def props subprimitive vocabulary }
+        filter-data-pointers
     ] [ entry_point>> 4 cell * - ] bi suffix ;
 
 M: object pointers ( heap heap-node struct -- seq )

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

@@ -1,5 +1,5 @@
-USING: alien.c-types alien.data assocs combinators.smart kernel math
+USING: alien.c-types alien.data assocs combinators.smart
-sequences ;
+compiler.constants kernel layouts math sequences vm ;
 IN: tools.image-analyzer.relocations
 
 CONSTANT: rel-params {
@@ -26,5 +26,16 @@ CONSTANT: rel-params {
 : byte-array>relocations ( byte-array -- relocations )
     uint cast-array [ uint>relocation ] { } map-as ;
 
-: load-relative-value ( byte-array relocation -- value )
+: decode-relative-relocation ( address byte-array relocation -- value )
-    third [ [ 4 - ] keep rot subseq int cast-array first ] keep + ;
+    third [ [ 4 - ] keep rot subseq int cast-array first ] keep + + ;
+
+: decode-absolute-relocation ( byte-array relocation -- value )
+    third [ cell - ] keep rot subseq cell_t cast-array first ;
+
+: interesting-relocation? ( relocation -- ? )
+    first { 1 2 3 6 } member? ;
+
+: decode-relocation ( address byte-array relocation -- value )
+    dup second rc-relative = [ decode-relative-relocation ] [
+        decode-absolute-relocation nip
+    ] if ;