tools.gc-decode: vocab for reading words gc maps

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

@@ -0,0 +1,44 @@
+USING: assocs help.markup help.syntax words ;
+IN: tools.gc-decode
+
+ARTICLE: "tools.gc-decode" "GC maps decoder"
+"A vocab that disassembles words gc maps. It's useful to have when debugging garbage collection issues." ;
+
+HELP: gc-info
+{ $class-description "A struct that defines the sizes of the garbage collection maps for a word. It has the following slots:"
+  { $table
+    { { $slot "scrub-d-count" } "Number of datastack scrub bits per callsite." }
+    { { $slot "scrub-r-count" } "Number of retainstack scrub bits per callsite." }
+    { { $slot "gc-root-count" } "Number of gc root bits per callsite." }
+    { { $slot "derived-root-count" } "Number of derived roots per callsite." }
+    { { $slot "return-address-count" } "Number of gc callsites." }
+  }
+} ;
+
+HELP: word>gc-info
+{ $values { "word" word } { "gc-info" gc-info } }
+{ $description "Gets the gc-info struct for a word." } ;
+
+HELP: decode-gc-maps
+{ $values { "word" word } { "assoc" assoc } }
+{ $description "Main word of the vocab. Decodes the gc maps for a word into an assoc with the following format:"
+  { $list
+    "Each key is the return addess of a gc callsite (delta relative to the start of the code block)."
+    {
+        "Each value is a two-tuple where:"
+        { $list
+          "The first element is a three-tuple containing the scrub patterns for the datastack, retainstack and gc roots."
+          "The second element is a sequence of derived roots for the callsite."
+        }
+    }
+  }
+}
+{ $examples
+  { $unchecked-example
+    "USING: effects prettyprint ;"
+    "\\ <effect> decode-gc-maps ."
+    "{ { 151 { { ?{ t } ?{ t t t } ?{ f t t t t } } { } } } }"
+  }
+} ;
+
+ABOUT: "tools.gc-decode"

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

@@ -0,0 +1,75 @@
+USING: bit-arrays classes.struct tools.gc-decode tools.test ;
+QUALIFIED: effects
+QUALIFIED: llvm.types
+QUALIFIED: unix.process
+IN: tools.gc-decode.tests
+
+! byte-array>bit-array
+{
+    ?{
+        t t t t f t t t
+        t f f f f f f f
+    }
+} [
+    B{ 239 1 } byte-array>bit-array
+] unit-test
+
+{ ?{ t t t t t t t t } } [ B{ 255 } byte-array>bit-array ] unit-test
+
+! scrub-bits
+{
+    ?{ t t t t f t t t t }
+} [
+    \ effects:<effect> word>gc-info scrub-bits
+] unit-test
+
+{
+    { }
+} [
+    \ decode-gc-maps word>gc-info scrub-bits
+] unit-test
+
+! decode-gc-maps
+{
+    {
+        { 151 { { ?{ t } ?{ t t t } ?{ f t t t t } } { } } }
+    }
+} [
+    \ effects:<effect> decode-gc-maps
+] unit-test
+
+{
+    {
+        { 82 { { ?{ t f f } ?{ t f } ?{ } } { } } }
+        { 244 { { ?{ t f f } ?{ f f } ?{ } } { } } }
+        { 522 { { ?{ t t f } ?{ t f } ?{ } } { } } }
+    }
+} [
+    \ unix.process:fork-process decode-gc-maps
+] unit-test
+
+! read-gc-maps
+{ { } } [
+    \ decode-gc-maps decode-gc-maps
+] unit-test
+
+! base-pointer-groups
+{
+
+    {
+        { -1 -1 -1 -1 -1 -1 -1 }
+        { -1 -1 -1 -1 -1 -1 -1 }
+        { -1 -1 -1 -1 -1 -1 5 }
+        { -1 -1 -1 -1 -1 -1 5 }
+    }
+} [
+    \ llvm.types:resolve-types word>gc-info base-pointer-groups
+] unit-test
+
+
+! One of the few words that has derived roots.
+{
+    S{ gc-info f 0 2 6 7 4 }
+} [
+    \ llvm.types:resolve-types word>gc-info
+] unit-test

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

@@ -0,0 +1,69 @@
+USING: accessors alien alien.c-types alien.data arrays assocs bit-arrays
+bit-arrays.private classes.struct fry grouping kernel math math.statistics
+sequences sequences.repeating words ;
+IN: tools.gc-decode
+
+! Utils
+: byte-array>bit-array ( byte-array -- bit-array )
+    [ integer>bit-array 8 f pad-tail ] { } map-as concat ;
+
+: split-indices ( seq indices -- parts )
+    over length suffix 0 prefix 2 clump [ first2 rot subseq ] with map ;
+
+: (cut-points) ( counts times -- seq )
+    <repeats> cum-sum but-last ;
+
+: reshape-sequence ( seq counts times -- seqs )
+    [ (cut-points) split-indices ] keep <groups> flip ;
+
+: end-address>direct-array ( obj count type -- seq )
+    [ heap-size * [ >c-ptr alien-address ] dip - <alien> ] 2keep
+    c-direct-array-constructor execute( alien len -- seq ) ;
+
+STRUCT: gc-info
+    { scrub-d-count uint read-only }
+    { scrub-r-count uint read-only }
+    { gc-root-count uint read-only }
+    { derived-root-count uint read-only }
+    { return-address-count uint read-only } ;
+
+: bit-counts ( gc-info -- counts )
+    struct-slot-values 3 head ;
+
+: total-bitmap-bits ( gc-info -- n )
+    [ bit-counts sum ] [ return-address-count>> ] bi * ;
+
+: return-addresses ( gc-info -- seq )
+    dup return-address-count>> uint end-address>direct-array ;
+
+: base-pointers ( gc-info -- seq )
+    [ return-addresses ]
+    [ return-address-count>> ]
+    [ derived-root-count>> ] tri *
+    int end-address>direct-array ;
+
+: base-pointer-groups ( gc-info -- seqs )
+    dup base-pointers
+    [ return-address-count>> { } <array> ]
+    [ swap derived-root-count>> <groups> [ >array ] map ] if-empty ;
+
+: scrub-bytes ( gc-info -- seq )
+    [ base-pointers ] [ total-bitmap-bits bits>bytes ] bi
+    uchar end-address>direct-array ;
+
+: scrub-bits ( gc-info -- seq )
+    [ scrub-bytes byte-array>bit-array ] keep total-bitmap-bits head ;
+
+: scrub-bit-groups ( gc-info -- scrub-groups )
+    [ scrub-bits ] [ bit-counts ] [ return-address-count>> ] tri
+    [ 2drop { } ] [ reshape-sequence ] if-zero ;
+
+: read-gc-maps ( gc-info -- assoc )
+    [ return-addresses ] [ scrub-bit-groups ] [ base-pointer-groups ] tri
+    zip zip ;
+
+: word>gc-info ( word -- gc-info )
+    word-code nip gc-info struct-size - <alien> gc-info memory>struct ;
+
+: decode-gc-maps ( word -- assoc )
+    word>gc-info read-gc-maps ;