1 USING: accessors arrays assocs classes classes.struct io
2 locals math.bitwise namespaces sequences tools.image-analyzer.utils
3 tools.image-analyzer.vm vm ;
4 IN: tools.image-analyzer.data-heap-reader
5 FROM: alien.c-types => char heap-size ;
6 FROM: kernel => bi dup keep nip swap ;
7 FROM: layouts => data-alignment ;
8 FROM: math => + - * align neg shift ;
10 : object-tag ( vm-object -- tag )
11 header>> 5 2 bit-range ;
13 GENERIC: read-payload ( rel-base struct -- tuple )
15 : remainder-padding ( payload-size vm-object -- n )
16 class-heap-size + dup data-alignment get align swap - ;
18 : seek-past-padding ( payload-size vm-object -- )
19 remainder-padding seek-relative seek-input ;
21 :: read-padded-payload ( count vm-object c-type -- payload )
22 count c-type heap-size * :> payload-size
24 c-type read-bytes>array
25 ] [ vm-object seek-past-padding ] bi ;
27 : read-array-payload ( vm-array -- payload )
28 [ capacity>> -4 shift ] keep cell read-padded-payload ;
30 : read-char-payload ( n-bytes vm-object -- payload )
31 char read-padded-payload ;
33 : read-no-payload ( vm-object -- payload )
34 0 swap seek-past-padding { } ;
36 : layout-address ( rel-base vm-tuple -- address )
37 layout>> 15 unmask - neg ;
39 M: array-payload read-payload ( rel-base vm-object -- payload )
40 nip read-array-payload ;
42 M: no-payload read-payload ( rel-base vm-object -- payload )
45 M: byte-array read-payload ( rel-base vm-object -- payload )
46 nip [ capacity>> -4 shift ] keep read-char-payload ;
48 M: string read-payload ( rel-base vm-string -- payload )
49 nip [ length>> -4 shift ] keep read-char-payload ;
51 M: tuple read-payload ( rel-base vm-tuple -- payload )
54 layout-address seek-absolute seek-input
55 tuple-layout read-struct size>> -4 shift
57 ] keep cell read-padded-payload ;
59 : peek-read-object ( -- vm-base )
60 [ object read-struct ] save-io-excursion ;
62 : (read-object) ( -- vm-object )
63 peek-read-object object-tag tag>class read-struct ;
65 : read-object ( rel-base -- object )
66 (read-object) [ read-payload ] keep swap 2array ;