extra/tools/gc-decode/gc-decode.factor

   1 USING: accessors alien alien.c-types alien.data arrays assocs bit-arrays
   2 bit-arrays.private classes.struct fry grouping kernel math math.statistics
   3 sequences sequences.repeating splitting vm words ;
   4 IN: tools.gc-decode
   5
   6 ! Utils
   7 : byte-array>bit-array ( byte-array -- bit-array )
   8     [ integer>bit-array 8 f pad-tail ] { } map-as concat ;
   9
  10 : (cut-points) ( counts times -- seq )
  11     <repeats> cum-sum but-last ;
  12
  13 : reshape-sequence ( seq counts times -- seqs )
  14     [ (cut-points) split-indices ] keep <groups> flip ;
  15
  16 : end-address>direct-array ( obj count type -- seq )
  17     [ heap-size * [ >c-ptr alien-address ] dip - <alien> ] 2keep
  18     c-direct-array-constructor execute( alien len -- seq ) ;
  19
  20 : bit-counts ( gc-info -- counts )
  21     struct-slot-values 5 head ;
  22
  23 : total-bitmap-bits ( gc-info -- n )
  24     [ bit-counts sum ] [ return-address-count>> ] bi * ;
  25
  26 : return-addresses ( gc-info -- seq )
  27     dup return-address-count>> uint end-address>direct-array ;
  28
  29 : base-pointers ( gc-info -- seq )
  30     [ return-addresses ]
  31     [ return-address-count>> ]
  32     [ derived-root-count>> ] tri *
  33     int end-address>direct-array ;
  34
  35 : base-pointer-groups ( gc-info -- seqs )
  36     dup base-pointers
  37     [ return-address-count>> { } <array> ]
  38     [ swap derived-root-count>> <groups> [ >array ] map ] if-empty ;
  39
  40 : scrub-bytes ( gc-info -- seq )
  41     [ base-pointers ] [ total-bitmap-bits bits>bytes ] bi
  42     uchar end-address>direct-array ;
  43
  44 : scrub-bits ( gc-info -- seq )
  45     [ scrub-bytes byte-array>bit-array ] keep total-bitmap-bits head ;
  46
  47 : scrub-bit-groups ( gc-info -- scrub-groups )
  48     [ scrub-bits ] [ bit-counts ] [ return-address-count>> ] tri
  49     [ 2drop { } ] [ reshape-sequence ] if-zero ;
  50
  51 : read-gc-maps ( gc-info -- assoc )
  52     [ return-addresses ] [ scrub-bit-groups ] [ base-pointer-groups ] tri
  53     zip zip ;
  54
  55 : word>gc-info ( word -- gc-info )
  56     word-code nip gc-info struct-size - <alien> gc-info memory>struct ;
  57
  58 : decode-gc-maps ( word -- assoc )
  59     word>gc-info read-gc-maps ;