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

   1 USING: accessors assocs classes.struct io locals math.bitwise
   2 namespaces system tools.image-analyzer.utils tools.image-analyzer.vm
   3 vm vocabs.parser vocabs.platforms ;
   4 IN: tools.image-analyzer.data-heap-reader
   5 FROM: alien.c-types => uchar heap-size ;
   6 FROM: arrays => 2array ;
   7 FROM: kernel => ? boa bi dup keep nip swap ;
   8 FROM: layouts => data-alignment ;
   9 FROM: math => + - * align neg shift ;
  10
  11 USE-X86-64: tools.image-analyzer.vm.64
  12 USE-X86-32: tools.image-analyzer.vm.32
  13
  14 : tag>class ( tag -- class )
  15     {
  16         { 2 array }
  17         { 3 boxed-float }
  18         { 4 quotation }
  19         { 5 bignum }
  20         { 6 alien }
  21         { 7 tuple }
  22         { 8 wrapper }
  23         { 9 byte-array }
  24         { 10 callstack }
  25         { 11 string }
  26         { 12 word }
  27         { 13 dll }
  28     } at ;
  29
  30 : object-tag ( object -- tag )
  31     header>> 5 2 bit-range ;
  32
  33 UNION: no-payload
  34     alien
  35     boxed-float
  36     dll
  37     quotation
  38     wrapper
  39     word ;
  40
  41 UNION: array-payload
  42     array
  43     bignum ;
  44
  45 GENERIC: read-payload ( rel-base struct -- tuple )
  46
  47 : remainder-padding ( payload-size object -- n )
  48     class-heap-size + dup data-alignment get align swap - ;
  49
  50 : seek-past-padding ( payload-size object -- )
  51     remainder-padding seek-relative seek-input ;
  52
  53 :: read-padded-payload ( count object c-type -- payload )
  54     count c-type heap-size * :> payload-size
  55     payload-size [
  56         c-type read-bytes>array
  57     ] [ object seek-past-padding ] bi ;
  58
  59 : read-array-payload ( array -- payload )
  60     [ capacity>> -4 shift ] keep cell_t read-padded-payload ;
  61
  62 : read-uchar-payload ( n-bytes object -- payload )
  63     uchar read-padded-payload ;
  64
  65 : read-no-payload ( object -- payload )
  66     0 swap seek-past-padding { } ;
  67
  68 : layout-address ( rel-base tuple -- address )
  69     layout>> untag - neg ;
  70
  71 M: array-payload read-payload ( rel-base object -- payload )
  72     nip read-array-payload ;
  73
  74 M: no-payload read-payload ( rel-base object -- payload )
  75     nip read-no-payload ;
  76
  77 M: byte-array read-payload ( rel-base object -- payload )
  78     nip [ capacity>> -4 shift ] keep read-uchar-payload ;
  79
  80 M: callstack read-payload ( rel-base object -- payload )
  81     nip [ length>> -4 shift ] keep read-uchar-payload ;
  82
  83 M: string read-payload ( rel-base string -- payload )
  84     nip [ length>> -4 shift ] keep read-uchar-payload ;
  85
  86 M: tuple read-payload ( rel-base tuple -- payload )
  87     [
  88         [
  89             layout-address seek-absolute seek-input
  90             tuple-layout read-struct size>> -4 shift
  91         ] save-io-excursion
  92     ] keep cell_t read-padded-payload ;
  93
  94 : peek-read-object ( -- object )
  95     [ object read-struct ] save-io-excursion ;
  96
  97 : (read-object) ( -- object )
  98     peek-read-object object-tag tag>class read-struct ;
  99
 100 : read-object ( rel-base -- object )
 101     tell-input swap (read-object) [ read-payload ] keep swap heap-node boa ;