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

   1 USING: accessors arrays assocs bit-arrays classes.struct combinators
   2 combinators.short-circuit compiler compiler.cfg.debugger
   3 compiler.cfg.instructions compiler.cfg.linearization
   4 compiler.cfg.stack-frame compiler.codegen.gc-maps compiler.units fry generic
   5 grouping io io.encodings.binary io.streams.byte-array kernel math namespaces
   6 random sequences sequences.generalizations
   7 tools.image-analyzer.gc-info tools.image-analyzer.utils tools.test vm
   8 vocabs words ;
   9 IN: tools.image-analyzer.gc-info.tests
  10 QUALIFIED: cpu.x86.features.private
  11 QUALIFIED: crypto.aes.utils
  12 QUALIFIED: effects
  13 QUALIFIED: gml.coremath
  14 QUALIFIED: llvm.types
  15 QUALIFIED: opencl
  16
  17 : normal? ( word -- ? )
  18     { [ generic? ] [ primitive? ] [ inline? ] [ no-compile? ] } 1|| not ;
  19
  20 : word>gc-info ( word -- gc-info )
  21     word>byte-array binary <byte-reader> <backwards-reader> [
  22         gc-info read-struct-safe
  23     ] with-input-stream ;
  24
  25 : word>scrub-bits ( word -- bits )
  26     word>byte-array binary <byte-reader> <backwards-reader> [
  27         gc-info read-struct-safe scrub-bits
  28     ] with-input-stream ;
  29
  30 : cfg>gc-maps ( cfg -- gc-maps )
  31     cfg>insns [ gc-map-insn? ] filter [ gc-map>> ] map
  32     [ gc-map-needed? ] filter ;
  33
  34 : tally-gc-maps ( gc-maps -- seq/f )
  35     [ f ] [ {
  36         [ [ scrub-d>> length ] map supremum ]
  37         [ [ scrub-r>> length ] map supremum ]
  38         [ [ gc-root-offsets ] map largest-spill-slot ]
  39         [ [ derived-root-offsets ] map [ keys ] map largest-spill-slot ]
  40         [ length ]
  41     } cleave 5 narray ] if-empty ;
  42
  43 ! Like word>gc-info but uses the compiler
  44 : word>gc-info-expected ( word -- seq/f )
  45     test-regs first dup stack-frame>> stack-frame
  46     [ cfg>gc-maps tally-gc-maps ] with-variable ;
  47
  48 : same-gc-info? ( compiler-gc-info gc-info -- ? )
  49     [ struct-slot-values = ]
  50     [ [ not ] dip return-address-count>> 0 = and ] 2bi or ;
  51
  52 : base-pointer-groups-expected ( word -- seq )
  53     test-regs first dup stack-frame>> stack-frame [
  54         cfg>gc-maps [ derived-root-offsets { } like ] { } map-as
  55     ] with-variable ;
  56
  57 : base-pointer-groups-decoded ( word -- seq )
  58     word>gc-maps [
  59         second second [ swap 2array ] map-index
  60         [ nip -1 = ] assoc-reject
  61     ] map ;
  62
  63 ! byte-array>bit-array
  64 {
  65     ?{
  66         t t t t f t t t
  67         t f f f f f f f
  68     }
  69 } [
  70     B{ 239 1 } byte-array>bit-array
  71 ] unit-test
  72
  73 { ?{ t t t t t t t t } } [ B{ 255 } byte-array>bit-array ] unit-test
  74
  75 ! scrub-bits
  76 {
  77     { { ?{ } ?{ } ?{ f f f f f } } }
  78 } [
  79     \ word>scrub-bits word>scrub-bits
  80 ] unit-test
  81
  82 ! decode-gc-maps
  83 { f } [
  84     \ effects:<effect> word>gc-maps empty?
  85 ] unit-test
  86
  87 { f } [
  88     \ + word>gc-maps empty?
  89 ] unit-test
  90
  91 { { } } [
  92     \ word>gc-maps word>gc-maps
  93 ] unit-test
  94
  95 ! Big test
  96 { { } } [
  97     all-words [ normal? ] filter 50 sample
  98     [ [ word>gc-info-expected ] [ word>gc-info ] bi same-gc-info? ] reject
  99 ] unit-test
 100
 101 ! base-pointer-groups
 102 { t } [
 103     \ llvm.types:resolve-types
 104     [ base-pointer-groups-expected ] [ base-pointer-groups-decoded ] bi =
 105 ] unit-test
 106
 107 ! Tough words #1227
 108 { t } [
 109     \ llvm.types:resolve-types
 110     [ word>gc-info-expected ] [ word>gc-info ] bi same-gc-info?
 111 ] unit-test
 112
 113 { t } [
 114     \ opencl:cl-queue-kernel
 115     [ word>gc-info-expected ] [ word>gc-info ] bi same-gc-info?
 116 ] unit-test
 117
 118 { t } [
 119     \ crypto.aes.utils:bytes>words
 120     [ word>gc-info-expected ] [ word>gc-info ] bi same-gc-info?
 121 ] unit-test
 122
 123 { t } [
 124     \ cpu.x86.features.private:(sse-version)
 125     [ word>gc-info-expected ] [ word>gc-info ] bi same-gc-info?
 126 ] unit-test
 127
 128 ! Ensure deterministic gc map generation.
 129 : recompile-word>gc-info ( word -- gc-info )
 130     [ 1array compile ] keep word>gc-info ;
 131
 132 : deterministic-gc-info? ( word -- ? )
 133     20 swap '[
 134         _ recompile-word>gc-info struct-slot-values
 135         dup last 0 = [ drop f ] when
 136     ] replicate all-equal? ;
 137
 138 { t t } [
 139     \ opencl:cl-queue-kernel deterministic-gc-info?
 140     \ gml.coremath:gml-determinant deterministic-gc-info?
 141 ] unit-test