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

   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 ;
   9
  10 : object-tag ( vm-object -- tag )
  11     header>> 5 2 bit-range ;
  12
  13 GENERIC: read-payload ( rel-base struct -- tuple )
  14
  15 : remainder-padding ( payload-size vm-object -- n )
  16     class-heap-size + dup data-alignment get align swap - ;
  17
  18 : seek-past-padding ( payload-size vm-object -- )
  19     remainder-padding seek-relative seek-input ;
  20
  21 :: read-padded-payload ( count vm-object c-type -- payload )
  22     count c-type heap-size * :> payload-size
  23     payload-size [
  24         c-type read-bytes>array
  25     ] [ vm-object seek-past-padding ] bi ;
  26
  27 : read-array-payload ( vm-array -- payload )
  28     [ capacity>> -4 shift ] keep cell read-padded-payload ;
  29
  30 : read-char-payload ( n-bytes vm-object -- payload )
  31     char read-padded-payload ;
  32
  33 : read-no-payload ( vm-object -- payload )
  34     0 swap seek-past-padding { } ;
  35
  36 : layout-address ( rel-base vm-tuple -- address )
  37     layout>> 15 unmask - neg ;
  38
  39 M: array-payload read-payload ( rel-base vm-object -- payload )
  40     nip read-array-payload ;
  41
  42 M: no-payload read-payload ( rel-base vm-object -- payload )
  43     nip read-no-payload ;
  44
  45 M: byte-array read-payload ( rel-base vm-object -- payload )
  46     nip [ capacity>> -4 shift ] keep read-char-payload ;
  47
  48 M: string read-payload ( rel-base vm-string -- payload )
  49     nip [ length>> -4 shift ] keep read-char-payload ;
  50
  51 M: tuple read-payload ( rel-base vm-tuple -- payload )
  52     [
  53         [
  54             layout-address seek-absolute seek-input
  55             tuple-layout read-struct size>> -4 shift
  56         ] save-io-excursion
  57     ] keep cell read-padded-payload ;
  58
  59 : peek-read-object ( -- vm-base )
  60     [ object read-struct ] save-io-excursion ;
  61
  62 : (read-object) ( -- vm-object )
  63     peek-read-object object-tag tag>class read-struct ;
  64
  65 : read-object ( rel-base -- object )
  66     (read-object) [ read-payload ] keep swap 2array ;