use reject instead of [ ... not ] filter.

[factor.git] / extra / tools / gc-decode / gc-decode-tests.factor

diff --git a/extra/tools/gc-decode/gc-decode-tests.factor b/extra/tools/gc-decode/gc-decode-tests.factor
index 8c8828298bf5c81895879779e453fffe0041d5b9..556c8b277af020838d58baab2da7ba11d099d3c9 100644 (file)
--- a/extra/tools/gc-decode/gc-decode-tests.factor
+++ b/extra/tools/gc-decode/gc-decode-tests.factor
@@ -1,11 +1,14 @@
 USING: accessors arrays assocs bit-arrays classes.struct combinators
 combinators.short-circuit compiler compiler.cfg.debugger
 compiler.cfg.instructions compiler.cfg.stack-frame compiler.cfg.utilities
-compiler.codegen.gc-maps generic kernel math namespaces random sequences
-sequences.generalizations slots.syntax tools.gc-decode tools.test vm vocabs
-words ;
+compiler.codegen.gc-maps compiler.units fry generic grouping kernel math
+namespaces random sequences sequences.generalizations slots.syntax
+tools.gc-decode tools.test vm vocabs words compiler.cfg.linearization ;
+QUALIFIED: cpu.x86.features.private
+QUALIFIED: crypto.aes.utils
 QUALIFIED: effects
 QUALIFIED: llvm.types
+QUALIFIED: opencl
 IN: tools.gc-decode.tests
 
 ! byte-array>bit-array
@@ -21,14 +24,6 @@ IN: tools.gc-decode.tests
 { ?{ t t t t t t t t } } [ B{ 255 } byte-array>bit-array ] unit-test
 
 ! scrub-bits
-{ t } [
-    \ effects:<effect> word>gc-info scrub-bits
-    {
-        ?{ t t t f t t t t } ! 64-bit
-        ?{ t t t f f f f f t t t t } ! 32-bit
-    } member?
-] unit-test
-
 {
     { }
 } [
@@ -57,12 +52,10 @@ IN: tools.gc-decode.tests
     [ f ] [ {
         [ [ scrub-d>> length ] map supremum ]
         [ [ scrub-r>> length ] map supremum ]
-        [ [ check-d>> length ] map supremum ]
-        [ [ check-r>> length ] map supremum ]
         [ [ gc-root-offsets ] map largest-spill-slot ]
         [ [ derived-root-offsets ] map [ keys ] map largest-spill-slot ]
         [ length ]
-    } cleave 7 narray ] if-empty ;
+    } cleave 5 narray ] if-empty ;
 
 ! Like word>gc-info but uses the compiler
 : word>gc-info-expected ( word -- seq/f )
@@ -73,19 +66,13 @@ IN: tools.gc-decode.tests
     [ struct-slot-values = ]
     [ [ not ] dip return-address-count>> 0 = and ] 2bi or ;
 
-! One of the few words that has derived roots.
-{ t } [
-    \ llvm.types:resolve-types
-    [ word>gc-info-expected ] [ word>gc-info ] bi same-gc-info?
-] unit-test
-
 ! Do it also for a bunch of random words
 : normal? ( word -- ? )
     { [ generic? ] [ primitive? ] [ inline? ] [ no-compile? ] } 1|| not ;
 
-{ t } [
-    all-words [ normal? ] filter 20 sample
-    [ [ word>gc-info-expected ] [ word>gc-info ] bi same-gc-info? ] all?
+{ { } } [
+    all-words [ normal? ] filter 50 sample
+    [ [ word>gc-info-expected ] [ word>gc-info ] bi same-gc-info? ] reject
 ] unit-test
 
 : base-pointer-groups-expected ( word -- seq )
@@ -103,3 +90,39 @@ IN: tools.gc-decode.tests
     \ 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 } [
+    \ opencl:cl-queue-kernel deterministic-gc-info?
+] unit-test