--- /dev/null
+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 <alien> -rot - <direct-uchar-array> >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 ;
--- /dev/null
+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 ;
--- /dev/null
+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 )
+ <repeats> cum-sum but-last ;
+
+: reshape-sequence ( seq counts times -- seqs )
+ [ (cut-points) split-indices ] keep <groups> 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 <byte-reader> <backwards-reader> [
+ gc-info read-struct-safe [
+ [ return-addresses ] [ base-pointers ] [ scrub-bits ] tri
+ swap zip zip
+ ] [ { } ] if*
+ ] with-input-stream ;
--- /dev/null
+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 ;
--- /dev/null
+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 <byte-reader> <backwards-reader> [
+ 4 read 4 read
+ ] with-input-stream
+] unit-test
--- /dev/null
+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* ;
+
+: <backwards-reader> ( stream -- stream' )
+ backwards-reader boa ;
--- /dev/null
+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 } ;
projects / factor.git / commitdiff