extra/tools/image-analyzer/data-heap-reader/data-heap-reader.factor

   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 => char 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 ;
  10
  11 <<
  12 ! For the two annoying structs that differ on 32 and 64 bit.
  13 cpu x86.32?
  14 "tools.image-analyzer.vm.32"
  15 "tools.image-analyzer.vm.64"
  16 ? use-vocab
  17 >>
  18
  19 : tag>class ( tag -- class )
  20     {
  21         { 2 array }
  22         { 3 boxed-float }
  23         { 4 quotation }
  24         { 5 bignum }
  25         { 6 alien }
  26         { 7 tuple }
  27         { 8 wrapper }
  28         { 9 byte-array }
  29         { 10 callstack }
  30         { 11 string }
  31         { 12 word }
  32         { 13 dll }
  33     } at ;
  34
  35 : object-tag ( object -- tag )
  36     header>> 5 2 bit-range ;
  37
  38 UNION: no-payload
  39     alien
  40     boxed-float
  41     dll
  42     quotation
  43     wrapper
  44     word ;
  45
  46 UNION: array-payload
  47     array
  48     bignum ;
  49
  50 GENERIC: read-payload ( rel-base struct -- tuple )
  51
  52 : remainder-padding ( payload-size object -- n )
  53     class-heap-size + dup data-alignment get align swap - ;
  54
  55 : seek-past-padding ( payload-size object -- )
  56     remainder-padding seek-relative seek-input ;
  57
  58 :: read-padded-payload ( count object c-type -- payload )
  59     count c-type heap-size * :> payload-size
  60     payload-size [
  61         c-type read-bytes>array
  62     ] [ object seek-past-padding ] bi ;
  63
  64 : read-array-payload ( array -- payload )
  65     [ capacity>> -4 shift ] keep cell read-padded-payload ;
  66
  67 : read-char-payload ( n-bytes object -- payload )
  68     char read-padded-payload ;
  69
  70 : read-no-payload ( object -- payload )
  71     0 swap seek-past-padding { } ;
  72
  73 : layout-address ( rel-base tuple -- address )
  74     layout>> 15 unmask - neg ;
  75
  76 M: array-payload read-payload ( rel-base object -- payload )
  77     nip read-array-payload ;
  78
  79 M: no-payload read-payload ( rel-base object -- payload )
  80     nip read-no-payload ;
  81
  82 M: byte-array read-payload ( rel-base object -- payload )
  83     nip [ capacity>> -4 shift ] keep read-char-payload ;
  84
  85 M: callstack read-payload ( rel-base object -- payload )
  86     nip [ length>> -4 shift ] keep read-char-payload ;
  87
  88 M: string read-payload ( rel-base string -- payload )
  89     nip [ length>> -4 shift ] keep read-char-payload ;
  90
  91 M: tuple read-payload ( rel-base tuple -- payload )
  92     [
  93         [
  94             layout-address seek-absolute seek-input
  95             tuple-layout read-struct size>> -4 shift
  96         ] save-io-excursion
  97     ] keep cell read-padded-payload ;
  98
  99 : peek-read-object ( -- object )
 100     [ object read-struct ] save-io-excursion ;
 101
 102 : (read-object) ( -- object )
 103     peek-read-object object-tag tag>class read-struct ;
 104
 105 : read-object ( rel-base -- object )
 106     (read-object) [ read-payload ] keep swap 2array ;