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

   1 USING: accessors alien alien.c-types byte-arrays classes.struct
   2 combinators io kernel math math.bitwise
   3 specialized-arrays.instances.alien.c-types.uchar
   4 tools.image-analyzer.gc-info tools.image-analyzer.vm vm words ;
   5 IN: tools.image-analyzer.code-heap-reader
   6 QUALIFIED: layouts
   7
   8 TUPLE: code-block-t free? owner parameters relocation gc-maps payload ;
   9
  10 : word>byte-array ( word -- array )
  11     word-code swap code-block heap-size -
  12     over <alien> -rot - <direct-uchar-array> >byte-array ;
  13
  14 : free? ( code-block -- ? )
  15     header>> 1 mask? ;
  16
  17 : size ( code-block -- n )
  18     header>> dup 1 mask? [ 7 unmask ] [ 0xfffff8 mask ] if ;
  19
  20 : (read-code-block) ( -- code-block payload )
  21     code-block [ read-struct ] [ heap-size ] bi over size swap - read ;
  22
  23 : >code-block< ( code-block -- free? owner parameters relocation )
  24     { [ free? ] [ owner>> ] [ parameters>> ] [ relocation>> ] } cleave ;
  25
  26 : read-code-block ( -- code-block )
  27     (read-code-block)
  28     [ >code-block< ] [ [ byte-array>gc-maps ] keep ] bi*
  29     code-block-t boa ;