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 generic kernel math namespaces random sequences
   5 sequences.generalizations slots.syntax tools.gc-decode tools.test vm vocabs
   6 words compiler.cfg.linearization ;
   7 QUALIFIED: effects
   8 QUALIFIED: llvm.types
   9 IN: tools.gc-decode.tests
  10
  11 ! byte-array>bit-array
  12 {
  13     ?{
  14         t t t t f t t t
  15         t f f f f f f f
  16     }
  17 } [
  18     B{ 239 1 } byte-array>bit-array
  19 ] unit-test
  20
  21 { ?{ t t t t t t t t } } [ B{ 255 } byte-array>bit-array ] unit-test
  22
  23 ! scrub-bits
  24 { t } [
  25     \ effects:<effect> word>gc-info scrub-bits
  26     {
  27         ?{ t t t f t t t t } ! 64-bit
  28         ?{ t t t f f f f f t t t t } ! 32-bit
  29     } member?
  30 ] unit-test
  31
  32 {
  33     { }
  34 } [
  35     \ decode-gc-maps word>gc-info scrub-bits
  36 ] unit-test
  37
  38 ! decode-gc-maps
  39 { f } [
  40     \ effects:<effect> decode-gc-maps empty?
  41 ] unit-test
  42
  43 { f } [
  44     \ + decode-gc-maps empty?
  45 ] unit-test
  46
  47 ! read-gc-maps
  48 { { } } [
  49     \ decode-gc-maps decode-gc-maps
  50 ] unit-test
  51
  52 : cfg>gc-maps ( cfg -- gc-maps )
  53     cfg>insns [ gc-map-insn? ] filter [ gc-map>> ] map
  54     [ gc-map-needed? ] filter ;
  55
  56 : tally-gc-maps ( gc-maps -- seq/f )
  57     [ f ] [ {
  58         [ [ scrub-d>> length ] map supremum ]
  59         [ [ scrub-r>> length ] map supremum ]
  60         [ [ check-d>> length ] map supremum ]
  61         [ [ check-r>> length ] map supremum ]
  62         [ [ gc-root-offsets ] map largest-spill-slot ]
  63         [ [ derived-root-offsets ] map [ keys ] map largest-spill-slot ]
  64         [ length ]
  65     } cleave 7 narray ] if-empty ;
  66
  67 ! Like word>gc-info but uses the compiler
  68 : word>gc-info-expected ( word -- seq/f )
  69     test-regs first dup stack-frame>> stack-frame
  70     [ cfg>gc-maps tally-gc-maps ] with-variable ;
  71
  72 : same-gc-info? ( compiler-gc-info gc-info -- ? )
  73     [ struct-slot-values = ]
  74     [ [ not ] dip return-address-count>> 0 = and ] 2bi or ;
  75
  76 ! One of the few words that has derived roots.
  77 { t } [
  78     \ llvm.types:resolve-types
  79     [ word>gc-info-expected ] [ word>gc-info ] bi same-gc-info?
  80 ] unit-test
  81
  82 ! Do it also for a bunch of random words
  83 : normal? ( word -- ? )
  84     { [ generic? ] [ primitive? ] [ inline? ] [ no-compile? ] } 1|| not ;
  85
  86 { { } } [
  87     all-words [ normal? ] filter 20 sample
  88     [ [ word>gc-info-expected ] [ word>gc-info ] bi same-gc-info? not ] filter
  89 ] unit-test
  90
  91 : base-pointer-groups-expected ( word -- seq )
  92     test-regs first dup stack-frame>> stack-frame [
  93         cfg>gc-maps [ derived-root-offsets { } like ] { } map-as
  94     ] with-variable ;
  95
  96 : base-pointer-groups-decoded ( word -- seq )
  97     word>gc-info base-pointer-groups [
  98         [ swap 2array ] map-index [ nip -1 = not ] assoc-filter
  99     ] map ;
 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