From 0f128cedb29b58ed6bf30824bb398f49518e58b8 Mon Sep 17 00:00:00 2001 From: =?utf8?q?Bj=C3=B6rn=20Lindqvist?= Date: Tue, 7 Jul 2015 16:42:58 +0200 Subject: [PATCH] tools.image-analyzer: new set of vocabs for reading and analyzing factor images --- .../code-heap-reader/code-heap-reader.factor | 29 ++++ .../data-heap-reader/data-heap-reader.factor | 66 ++++++++++ .../image-analyzer/gc-info/gc-info.factor | 47 +++++++ .../image-analyzer/image-analyzer.factor | 20 +++ .../image-analyzer/utils/utils-tests.factor | 12 ++ extra/tools/image-analyzer/utils/utils.factor | 53 ++++++++ extra/tools/image-analyzer/vm/vm.factor | 124 ++++++++++++++++++ 7 files changed, 351 insertions(+) create mode 100644 extra/tools/image-analyzer/code-heap-reader/code-heap-reader.factor create mode 100644 extra/tools/image-analyzer/data-heap-reader/data-heap-reader.factor create mode 100644 extra/tools/image-analyzer/gc-info/gc-info.factor create mode 100644 extra/tools/image-analyzer/image-analyzer.factor create mode 100644 extra/tools/image-analyzer/utils/utils-tests.factor create mode 100644 extra/tools/image-analyzer/utils/utils.factor create mode 100644 extra/tools/image-analyzer/vm/vm.factor diff --git a/extra/tools/image-analyzer/code-heap-reader/code-heap-reader.factor b/extra/tools/image-analyzer/code-heap-reader/code-heap-reader.factor new file mode 100644 index 0000000000..8a9f745d18 --- /dev/null +++ b/extra/tools/image-analyzer/code-heap-reader/code-heap-reader.factor @@ -0,0 +1,29 @@ +USING: accessors alien alien.c-types byte-arrays classes.struct +combinators io kernel math math.bitwise +specialized-arrays.instances.alien.c-types.uchar +tools.image-analyzer.gc-info tools.image-analyzer.vm vm words ; +IN: tools.image-analyzer.code-heap-reader +QUALIFIED: layouts + +TUPLE: code-block-t free? owner parameters relocation gc-maps payload ; + +: word>byte-array ( word -- array ) + word-code swap code-block heap-size - + over -rot - >byte-array ; + +: free? ( code-block -- ? ) + header>> 1 mask? ; + +: size ( code-block -- n ) + header>> dup 1 mask? [ 7 unmask ] [ 0xfffff8 mask ] if ; + +: (read-code-block) ( -- code-block payload ) + code-block [ read-struct ] [ heap-size ] bi over size swap - read ; + +: >code-block< ( code-block -- free? owner parameters relocation ) + { [ free? ] [ owner>> ] [ parameters>> ] [ relocation>> ] } cleave ; + +: read-code-block ( -- code-block ) + (read-code-block) + [ >code-block< ] [ [ byte-array>gc-maps ] keep ] bi* + code-block-t boa ; diff --git a/extra/tools/image-analyzer/data-heap-reader/data-heap-reader.factor b/extra/tools/image-analyzer/data-heap-reader/data-heap-reader.factor new file mode 100644 index 0000000000..67c5a3694b --- /dev/null +++ b/extra/tools/image-analyzer/data-heap-reader/data-heap-reader.factor @@ -0,0 +1,66 @@ +USING: accessors arrays assocs classes classes.struct io +locals math.bitwise namespaces sequences tools.image-analyzer.utils +tools.image-analyzer.vm vm ; +IN: tools.image-analyzer.data-heap-reader +FROM: alien.c-types => char heap-size ; +FROM: kernel => bi dup keep nip swap ; +FROM: layouts => data-alignment ; +FROM: math => + - * align neg shift ; + +: object-tag ( vm-object -- tag ) + header>> 5 2 bit-range ; + +GENERIC: read-payload ( rel-base struct -- tuple ) + +: remainder-padding ( payload-size vm-object -- n ) + class-heap-size + dup data-alignment get align swap - ; + +: seek-past-padding ( payload-size vm-object -- ) + remainder-padding seek-relative seek-input ; + +:: read-padded-payload ( count vm-object c-type -- payload ) + count c-type heap-size * :> payload-size + payload-size [ + c-type read-bytes>array + ] [ vm-object seek-past-padding ] bi ; + +: read-array-payload ( vm-array -- payload ) + [ capacity>> -4 shift ] keep cell read-padded-payload ; + +: read-char-payload ( n-bytes vm-object -- payload ) + char read-padded-payload ; + +: read-no-payload ( vm-object -- payload ) + 0 swap seek-past-padding { } ; + +: layout-address ( rel-base vm-tuple -- address ) + layout>> 15 unmask - neg ; + +M: array-payload read-payload ( rel-base vm-object -- payload ) + nip read-array-payload ; + +M: no-payload read-payload ( rel-base vm-object -- payload ) + nip read-no-payload ; + +M: byte-array read-payload ( rel-base vm-object -- payload ) + nip [ capacity>> -4 shift ] keep read-char-payload ; + +M: string read-payload ( rel-base vm-string -- payload ) + nip [ length>> -4 shift ] keep read-char-payload ; + +M: tuple read-payload ( rel-base vm-tuple -- payload ) + [ + [ + layout-address seek-absolute seek-input + tuple-layout read-struct size>> -4 shift + ] save-io-excursion + ] keep cell read-padded-payload ; + +: peek-read-object ( -- vm-base ) + [ object read-struct ] save-io-excursion ; + +: (read-object) ( -- vm-object ) + peek-read-object object-tag tag>class read-struct ; + +: read-object ( rel-base -- object ) + (read-object) [ read-payload ] keep swap 2array ; diff --git a/extra/tools/image-analyzer/gc-info/gc-info.factor b/extra/tools/image-analyzer/gc-info/gc-info.factor new file mode 100644 index 0000000000..9545c524f8 --- /dev/null +++ b/extra/tools/image-analyzer/gc-info/gc-info.factor @@ -0,0 +1,47 @@ +USING: accessors alien.c-types alien.data arrays assocs +bit-arrays.private classes.struct fry grouping io io.encodings.binary +io.streams.byte-array kernel math math.statistics sequences +sequences.repeating splitting tools.image-analyzer.utils vm ; +IN: tools.image-analyzer.gc-info + +! Utils +: read-ints ( count -- seq ) + int read-array ; + +: read-bits ( bit-count -- bit-array ) + [ bits>bytes read byte-array>bit-array ] keep head ; + +: (cut-points) ( counts times -- seq ) + cum-sum but-last ; + +: reshape-sequence ( seq counts times -- seqs ) + [ (cut-points) split-indices ] keep flip ; + +: read-struct-safe ( struct -- instance/f ) + dup heap-size read [ swap memory>struct ] [ drop f ] if* ; + +! Real stuff +: return-addresses ( gc-info -- seq ) + return-address-count>> read-ints ; + +: base-pointers ( gc-info -- seq ) + [ return-address-count>> ] keep derived-root-count>> + '[ _ read-ints ] replicate ; + +: bit-counts ( gc-info -- counts ) + struct-slot-values 3 head ; + +: (read-scrub-bits) ( gc-info -- seq ) + [ bit-counts sum ] [ return-address-count>> ] bi * read-bits ; + +: scrub-bits ( gc-info -- seq ) + [ (read-scrub-bits) ] [ bit-counts ] [ return-address-count>> ] tri + [ 2drop { } ] [ reshape-sequence ] if-zero ; + +: byte-array>gc-maps ( byte-array -- gc-maps ) + binary [ + gc-info read-struct-safe [ + [ return-addresses ] [ base-pointers ] [ scrub-bits ] tri + swap zip zip + ] [ { } ] if* + ] with-input-stream ; diff --git a/extra/tools/image-analyzer/image-analyzer.factor b/extra/tools/image-analyzer/image-analyzer.factor new file mode 100644 index 0000000000..a7cc1f8158 --- /dev/null +++ b/extra/tools/image-analyzer/image-analyzer.factor @@ -0,0 +1,20 @@ +USING: accessors arrays assocs classes.struct fry io io.encodings.binary +io.files io.streams.byte-array kernel kernel.private math sequences +tools.image-analyzer.code-heap-reader tools.image-analyzer.data-heap-reader +tools.image-analyzer.utils tools.image-analyzer.vm vm ; +IN: tools.image-analyzer + +: code-heap>code-blocks ( code-heap -- code-blocks ) + binary [ [ read-code-block ] consume-stream>sequence ] with-byte-reader ; + +: data-heap>objects ( data-relocation-base data-heap -- object-assoc ) + binary [ '[ _ read-object ] consume-stream>sequence ] with-byte-reader ; + +: load-image ( image -- header data-heap code-heap ) + binary [ + image-header read-struct dup [ + [ data-relocation-base>> ] [ data-size>> read ] bi + data-heap>objects + ] + [ code-size>> read code-heap>code-blocks ] bi + ] with-file-reader ; diff --git a/extra/tools/image-analyzer/utils/utils-tests.factor b/extra/tools/image-analyzer/utils/utils-tests.factor new file mode 100644 index 0000000000..9dabaaba03 --- /dev/null +++ b/extra/tools/image-analyzer/utils/utils-tests.factor @@ -0,0 +1,12 @@ +USING: io io.encodings.binary io.streams.byte-array +tools.image-analyzer.utils tools.test ; +IN: tools.image-analyzer.utils.tests + +{ + B{ 5 6 7 8 } + B{ 1 2 3 4 } +} [ + B{ 1 2 3 4 5 6 7 8 } binary [ + 4 read 4 read + ] with-input-stream +] unit-test diff --git a/extra/tools/image-analyzer/utils/utils.factor b/extra/tools/image-analyzer/utils/utils.factor new file mode 100644 index 0000000000..b09e0975bf --- /dev/null +++ b/extra/tools/image-analyzer/utils/utils.factor @@ -0,0 +1,53 @@ +USING: accessors alien.c-types alien.data arrays bit-arrays classes +continuations destructors fry io io.streams.throwing kernel locals +math namespaces sequences ; +IN: tools.image-analyzer.utils + +: class-heap-size ( instance -- n ) + class-of heap-size ; + +: read-bytes>array ( nbytes type -- seq ) + [ read ] dip cast-array >array ; + +: read-array ( count type -- seq ) + [ heap-size * ] keep read-bytes>array ; + +: byte-array>bit-array ( byte-array -- bit-array ) + [ integer>bit-array 8 f pad-tail ] { } map-as concat ; + +: until-eof-reader ( reader-quot -- reader-quot' ) + '[ + [ [ @ ] throw-on-eof ] [ + dup stream-exhausted? [ drop f ] [ throw ] if + ] recover + ] ; inline + +: save-io-excursion ( quot -- ) + tell-input '[ _ seek-absolute seek-input ] [ ] cleanup ; inline + +: consume-stream>sequence ( reader-quot: ( -- item ) -- seq ) + until-eof-reader '[ drop @ ] t swap follow rest ; inline + +TUPLE: backwards-reader stream ; + +M: backwards-reader dispose stream>> dispose ; + +M: backwards-reader stream-element-type + stream>> stream-element-type ; + +M: backwards-reader stream-length + stream>> stream-length ; + +: backwards-seek ( ofs -- ) + dup 0 < [ seek-end ] [ seek-absolute ] if seek-input ; + +M:: backwards-reader stream-read-unsafe ( n buf stream -- count ) + stream stream>> [ + tell-input n + :> pos-after + pos-after neg backwards-seek + n buf input-stream get stream-read-unsafe + pos-after backwards-seek + ] with-input-stream* ; + +: ( stream -- stream' ) + backwards-reader boa ; diff --git a/extra/tools/image-analyzer/vm/vm.factor b/extra/tools/image-analyzer/vm/vm.factor new file mode 100644 index 0000000000..eea438ad8e --- /dev/null +++ b/extra/tools/image-analyzer/vm/vm.factor @@ -0,0 +1,124 @@ +USING: alien.c-types assocs classes.struct kernel.private vm ; +IN: tools.image-analyzer.vm + +! These structs and words correspond to vm/image.hpp +STRUCT: image-header + { magic cell } + { version cell } + { data-relocation-base cell } + { data-size cell } + { code-relocation-base cell } + { code-size cell } + { true-object cell } + { bignum-zero cell } + { bignum-pos-one cell } + { bignum-neg-one cell } + { special-objects cell[special-object-count] } ; + +! These structs and words correspond to vm/layouts.hpp +STRUCT: object + { header cell } ; + +STRUCT: alien + { header cell } + { base cell } + { expired cell } + { displacement cell } + { address cell } ; + +STRUCT: array + { header cell } + { capacity cell } ; + +STRUCT: bignum + { header cell } + { capacity cell } ; + +! Different on 32 bit +STRUCT: byte-array + { header cell } + { capacity cell } ; + +STRUCT: dll + { header cell } + { path cell } + { handle void* } ; + +! Different on 32 bit +STRUCT: float + { header cell } + { n double } ; + +STRUCT: quotation + { header cell } + { array cell } + { cached_effect cell } + { cache_counter cell } + { entry_point cell } ; + +STRUCT: string + { header cell } + { length cell } + { aux cell } + { hashcode cell } ; + +STRUCT: tuple + { header cell } + { layout cell } ; + +STRUCT: tuple-layout + { header cell } + { capacity cell } + { klass cell } + { size cell } + { echelon cell } ; + +STRUCT: word + { header cell } + { hashcode cell } + { name cell } + { vocabulary cell } + { def cell } + { props cell } + { pic_def cell } + { pic_tail_def cell } + { subprimitive cell } + { entry_point cell } ; + +STRUCT: wrapper + { header cell } + { object cell } ; + +UNION: no-payload + alien + dll + float + quotation + wrapper + word ; + +UNION: array-payload + array + bignum ; + +: tag>class ( tag -- class ) + { + { 2 array } + { 3 float } + { 4 quotation } + { 5 bignum } + { 6 alien } + { 7 tuple } + { 8 wrapper } + { 9 byte-array } + { 11 string } + { 12 word } + { 13 dll } + } at ; + +! These structs and words correspond to vm/code_blocks.hpp +STRUCT: code-block + { header cell } + { owner cell } + { parameters cell } + { relocation cell } ; -- 2.34.1