diff --git a/extra/tools/image-analyzer/image-analyzer-tests.factor b/extra/tools/image-analyzer/image-analyzer-tests.factor index a29c793433..0c17563623 100644 --- a/extra/tools/image-analyzer/image-analyzer-tests.factor +++ b/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 diff --git a/extra/tools/image-analyzer/references/references.factor b/extra/tools/image-analyzer/references/references.factor index 89345d8c2f..b5be4c3447 100644 --- a/extra/tools/image-analyzer/references/references.factor +++ b/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 -sequences slots.syntax tools.image-analyzer.relocations ; +USING: accessors arrays byte-arrays fry kernel layouts math +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 ) diff --git a/extra/tools/image-analyzer/relocations/relocations.factor b/extra/tools/image-analyzer/relocations/relocations.factor index 1d6b8297ca..c87dfea2ef 100644 --- a/extra/tools/image-analyzer/relocations/relocations.factor +++ b/extra/tools/image-analyzer/relocations/relocations.factor @@ -1,5 +1,5 @@ -USING: alien.c-types alien.data assocs combinators.smart kernel math -sequences ; +USING: alien.c-types alien.data assocs combinators.smart +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 ) - third [ [ 4 - ] keep rot subseq int cast-array first ] keep + ; +: decode-relative-relocation ( address byte-array relocation -- value ) + 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 ;