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