tools.image-analyzer: new set of vocabs for reading and analyzing factor images
Björn Lindqvist
parent
7780a48c83
commit
0f128cedb2
|
|
@ -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 <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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 )
|
||||
<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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 <byte-reader> <backwards-reader> [
|
||||
4 read 4 read
|
||||
] with-input-stream
|
||||
] unit-test
|
||||
|
|
@ -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* ;
|
||||
|
||||
: <backwards-reader> ( stream -- stream' )
|
||||
backwards-reader boa ;
|
||||
|
|
@ -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 } ;
|
||||
Loading…
Reference in New Issue