1 USING: accessors assocs classes classes.struct io locals
2 math.bitwise namespaces sequences system tools.image-analyzer.utils
3 tools.image-analyzer.vm vm vocabs.parser ;
4 IN: tools.image-analyzer.data-heap-reader
5 FROM: alien.c-types => uchar heap-size ;
6 FROM: arrays => 2array ;
7 FROM: kernel => ? bi dup keep nip swap ;
8 FROM: layouts => data-alignment ;
9 FROM: math => + - * align neg shift ;
12 ! For the two annoying structs that differ on 32 and 64 bit.
14 "tools.image-analyzer.vm.32"
15 "tools.image-analyzer.vm.64"
19 : tag>class ( tag -- class )
35 : object-tag ( object -- tag )
36 header>> 5 2 bit-range ;
50 GENERIC: read-payload ( rel-base struct -- tuple )
52 : remainder-padding ( payload-size object -- n )
53 class-heap-size + dup data-alignment get align swap - ;
55 : seek-past-padding ( payload-size object -- )
56 remainder-padding seek-relative seek-input ;
58 :: read-padded-payload ( count object c-type -- payload )
59 count c-type heap-size * :> payload-size
61 c-type read-bytes>array
62 ] [ object seek-past-padding ] bi ;
64 : read-array-payload ( array -- payload )
65 [ capacity>> -4 shift ] keep cell read-padded-payload ;
67 : read-uchar-payload ( n-bytes object -- payload )
68 uchar read-padded-payload ;
70 : read-no-payload ( object -- payload )
71 0 swap seek-past-padding { } ;
73 : layout-address ( rel-base tuple -- address )
74 layout>> 15 unmask - neg ;
76 M: array-payload read-payload ( rel-base object -- payload )
77 nip read-array-payload ;
79 M: no-payload read-payload ( rel-base object -- payload )
82 M: byte-array read-payload ( rel-base object -- payload )
83 nip [ capacity>> -4 shift ] keep read-uchar-payload ;
85 M: callstack read-payload ( rel-base object -- payload )
86 nip [ length>> -4 shift ] keep read-uchar-payload ;
88 M: string read-payload ( rel-base string -- payload )
89 nip [ length>> -4 shift ] keep read-uchar-payload ;
91 M: tuple read-payload ( rel-base tuple -- payload )
94 layout-address seek-absolute seek-input
95 tuple-layout read-struct size>> -4 shift
97 ] keep cell read-padded-payload ;
99 : peek-read-object ( -- object )
100 [ object read-struct ] save-io-excursion ;
102 : (read-object) ( -- object )
103 peek-read-object object-tag tag>class read-struct ;
105 : read-object ( rel-base -- object )
106 (read-object) [ read-payload ] keep swap 2array ;