tools.image-analyzer.gc-info.tests: "translates" all the tests from tools.gc-decode.tests

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

@@ -1,16 +1,10 @@
-USING: accessors alien alien.c-types byte-arrays classes.struct
+USING: accessors alien.c-types classes.struct combinators io kernel
-combinators io kernel math math.bitwise
+math math.bitwise tools.image-analyzer.gc-info tools.image-analyzer.vm ;
-specialized-arrays.instances.alien.c-types.uchar
-tools.image-analyzer.gc-info tools.image-analyzer.vm vm words ;
 IN: tools.image-analyzer.code-heap-reader
 QUALIFIED: layouts
 
 TUPLE: code-block-t free? owner parameters relocation gc-maps payload ;
 
-: word>byte-array ( word -- array )
-    word-code swap code-block heap-size -
-    over <alien> -rot - <direct-uchar-array> >byte-array ;
-
 : free? ( code-block -- ? )
     header>> 1 mask? ;
 

extra/tools/image-analyzer/gc-info/gc-info-tests.factor

@@ -0,0 +1,141 @@
+USING: accessors arrays assocs bit-arrays classes.struct combinators
+combinators.short-circuit compiler compiler.cfg.debugger
+compiler.cfg.instructions compiler.cfg.linearization
+compiler.cfg.stack-frame compiler.codegen.gc-maps compiler.units fry generic
+grouping io io.encodings.binary io.streams.byte-array kernel math namespaces
+random sequences sequences.generalizations
+tools.image-analyzer.gc-info tools.image-analyzer.utils tools.test vm
+vocabs words ;
+IN: tools.image-analyzer.gc-info.tests
+QUALIFIED: cpu.x86.features.private
+QUALIFIED: crypto.aes.utils
+QUALIFIED: effects
+QUALIFIED: gml.coremath
+QUALIFIED: llvm.types
+QUALIFIED: opencl
+
+: normal? ( word -- ? )
+    { [ generic? ] [ primitive? ] [ inline? ] [ no-compile? ] } 1|| not ;
+
+: word>gc-info ( word -- gc-info )
+    word>byte-array binary <byte-reader> <backwards-reader> [
+        gc-info read-struct-safe
+    ] with-input-stream ;
+
+: word>scrub-bits ( word -- bits )
+    word>byte-array binary <byte-reader> <backwards-reader> [
+        gc-info read-struct-safe scrub-bits
+    ] with-input-stream ;
+
+: cfg>gc-maps ( cfg -- gc-maps )
+    cfg>insns [ gc-map-insn? ] filter [ gc-map>> ] map
+    [ gc-map-needed? ] filter ;
+
+: tally-gc-maps ( gc-maps -- seq/f )
+    [ f ] [ {
+        [ [ scrub-d>> length ] map supremum ]
+        [ [ scrub-r>> length ] map supremum ]
+        [ [ gc-root-offsets ] map largest-spill-slot ]
+        [ [ derived-root-offsets ] map [ keys ] map largest-spill-slot ]
+        [ length ]
+    } cleave 5 narray ] if-empty ;
+
+! Like word>gc-info but uses the compiler
+: word>gc-info-expected ( word -- seq/f )
+    test-regs first dup stack-frame>> stack-frame
+    [ cfg>gc-maps tally-gc-maps ] with-variable ;
+
+: same-gc-info? ( compiler-gc-info gc-info -- ? )
+    [ struct-slot-values = ]
+    [ [ not ] dip return-address-count>> 0 = and ] 2bi or ;
+
+: base-pointer-groups-expected ( word -- seq )
+    test-regs first dup stack-frame>> stack-frame [
+        cfg>gc-maps [ derived-root-offsets { } like ] { } map-as
+    ] with-variable ;
+
+: base-pointer-groups-decoded ( word -- seq )
+    word>gc-maps [
+        second second [ swap 2array ] map-index
+        [ nip -1 = ] assoc-reject
+    ] map ;
+
+! 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
+{
+    { { ?{ } ?{ } ?{ f f f f f } } }
+} [
+    \ word>scrub-bits word>scrub-bits
+] unit-test
+
+! decode-gc-maps
+{ f } [
+    \ effects:<effect> word>gc-maps empty?
+] unit-test
+
+{ f } [
+    \ + word>gc-maps empty?
+] unit-test
+
+{ { } } [
+    \ word>gc-maps word>gc-maps
+] unit-test
+
+! Big test
+{ { } } [
+    all-words [ normal? ] filter 50 sample
+    [ [ word>gc-info-expected ] [ word>gc-info ] bi same-gc-info? ] reject
+] unit-test
+
+! base-pointer-groups
+{ t } [
+    \ llvm.types:resolve-types
+    [ base-pointer-groups-expected ] [ base-pointer-groups-decoded ] bi =
+] unit-test
+
+! Tough words #1227
+{ t } [
+    \ llvm.types:resolve-types
+    [ word>gc-info-expected ] [ word>gc-info ] bi same-gc-info?
+] unit-test
+
+{ t } [
+    \ opencl:cl-queue-kernel
+    [ word>gc-info-expected ] [ word>gc-info ] bi same-gc-info?
+] unit-test
+
+{ t } [
+    \ crypto.aes.utils:bytes>words
+    [ word>gc-info-expected ] [ word>gc-info ] bi same-gc-info?
+] unit-test
+
+{ t } [
+    \ cpu.x86.features.private:(sse-version)
+    [ word>gc-info-expected ] [ word>gc-info ] bi same-gc-info?
+] unit-test
+
+! Ensure deterministic gc map generation.
+: recompile-word>gc-info ( word -- gc-info )
+    [ 1array compile ] keep word>gc-info ;
+
+: deterministic-gc-info? ( word -- ? )
+    20 swap '[
+        _ recompile-word>gc-info struct-slot-values
+        dup last 0 = [ drop f ] when
+    ] replicate all-equal? ;
+
+{ t t } [
+    \ opencl:cl-queue-kernel deterministic-gc-info?
+    \ gml.coremath:gml-determinant deterministic-gc-info?
+] unit-test

extra/tools/image-analyzer/gc-info/gc-info.factor

@@ -26,7 +26,7 @@ IN: tools.image-analyzer.gc-info
 
 : base-pointers ( gc-info -- seq )
     [ return-address-count>> ] keep derived-root-count>>
-    '[ _ read-ints ] replicate ;
+    '[ _ read-ints ] replicate <reversed> ;
 
 : bit-counts ( gc-info -- counts )
     struct-slot-values 3 head ;
@@ -45,3 +45,6 @@ IN: tools.image-analyzer.gc-info
             swap zip zip
         ] [ { } ] if*
     ] with-input-stream ;
+
+: word>gc-maps ( word -- gc-maps )
+    word>byte-array byte-array>gc-maps ;

extra/tools/image-analyzer/utils/utils.factor

@@ -1,6 +1,6 @@
-USING: accessors alien.c-types alien.data arrays bit-arrays classes
+USING: accessors alien alien.c-types alien.data arrays bit-arrays classes
 continuations destructors fry io io.streams.throwing kernel locals
-math namespaces sequences ;
+math namespaces sequences words ;
 IN: tools.image-analyzer.utils
 
 : class-heap-size ( instance -- n )
@@ -15,6 +15,9 @@ IN: tools.image-analyzer.utils
 : byte-array>bit-array ( byte-array -- bit-array )
     [ integer>bit-array 8 f pad-tail ] { } map-as concat ;
 
+: word>byte-array ( word -- byte-array )
+    word-code over - [ <alien> ] dip memory>byte-array ;
+
 : until-eof-reader ( reader-quot -- reader-quot' )
     '[
         [ [ @ ] throw-on-eof ] [