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

   1 USING: accessors alien.c-types alien.syntax arrays assocs bit-arrays
   2 classes.struct combinators combinators.short-circuit compiler compiler.cfg
   3 compiler.cfg.debugger 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: gtk-samples.opengl
  14 QUALIFIED: opencl
  15
  16 : normal? ( word -- ? )
  17     { [ generic? ] [ primitive? ] [ inline? ] [ no-compile? ] } 1|| not ;
  18
  19 : word>gc-info ( word -- gc-info )
  20     word>byte-array binary <byte-reader> <backwards-reader> [
  21         gc-info read-struct-safe
  22     ] with-input-stream ;
  23
  24 : cfg>gc-maps ( cfg -- gc-maps )
  25     cfg>insns [ gc-map-insn? ] filter [ gc-map>> ] map
  26     [ gc-map-needed? ] filter ;
  27
  28 : tally-gc-maps ( gc-maps -- seq/f )
  29     [ f ] [ {
  30         [ [ scrub-d>> length ] map supremum ]
  31         [ [ scrub-r>> length ] map supremum ]
  32         [ [ gc-root-offsets ] map largest-spill-slot ]
  33         [ [ derived-root-offsets ] map [ keys ] map largest-spill-slot ]
  34         [ length ]
  35     } cleave 5 narray ] if-empty ;
  36
  37 ! Like word>gc-info but uses the compiler
  38 : word>gc-info-expected ( word -- seq/f )
  39     test-regs first [ cfg set ] [ cfg>gc-maps tally-gc-maps ] bi ;
  40
  41 ! Handle f f as input. Deferred words don't have any gc-info. See #1394.
  42 : same-gc-info? ( compiler-gc-info/f gc-info/f -- ? )
  43     2dup = [
  44         2drop t
  45     ] [
  46         [ struct-slot-values = ]
  47         [ [ not ] dip return-address-count>> 0 = and ] 2bi or
  48     ] if ;
  49
  50 : base-pointer-groups-expected ( word -- seq )
  51     test-regs first cfg>gc-maps [ derived-root-offsets { } like ] { } map-as ;
  52
  53 : base-pointer-groups-decoded ( word -- seq )
  54     word>gc-maps [
  55         second second [ swap 2array ] map-index
  56         [ nip -1 = ] assoc-reject
  57     ] map ;
  58
  59 ! byte-array>bit-array
  60 {
  61     ?{
  62         t t t t f t t t
  63         t f f f f f f f
  64     }
  65 } [
  66     B{ 239 1 } byte-array>bit-array
  67 ] unit-test
  68
  69 { ?{ t t t t t t t t } } [ B{ 255 } byte-array>bit-array ] unit-test
  70
  71 ! word>gc-maps
  72 { f } [
  73     \ effects:<effect> word>gc-maps empty?
  74 ] unit-test
  75
  76 { f } [
  77     \ + word>gc-maps empty?
  78 ] unit-test
  79
  80 { { } } [
  81     \ word>gc-maps word>gc-maps
  82 ] unit-test
  83
  84 ! Big test
  85 { { } } [
  86     all-words [ normal? ] filter 50 sample
  87     [ [ word>gc-info-expected ] [ word>gc-info ] bi same-gc-info? ] reject
  88 ] unit-test
  89
  90
  91 ! Originally from llvm.types, but llvm moved to unmaintained
  92 TYPEDEF: void* LLVMTypeRef
  93 TYPEDEF: void* LLVMTypeHandleRef
  94 FUNCTION: LLVMTypeRef LLVMResolveTypeHandle ( LLVMTypeHandleRef TypeHandle )
  95 FUNCTION: LLVMTypeHandleRef LLVMCreateTypeHandle ( LLVMTypeRef PotentiallyAbstractTy )
  96 FUNCTION: void LLVMRefineType ( LLVMTypeRef AbstractTy, LLVMTypeRef ConcreteTy )
  97 FUNCTION: void LLVMDisposeTypeHandle ( LLVMTypeHandleRef TypeHandle )
  98
  99 : resolve-types ( typeref typeref -- typeref )
 100     over LLVMCreateTypeHandle [ LLVMRefineType ] dip
 101     [ LLVMResolveTypeHandle ] keep LLVMDisposeTypeHandle ;
 102
 103 ! base-pointer-groups
 104 { t } [
 105     \ resolve-types
 106     [ base-pointer-groups-expected ] [ base-pointer-groups-decoded ] bi =
 107 ] unit-test
 108
 109
 110 ! Tough words #1227
 111 { t } [
 112     \ resolve-types
 113     [ word>gc-info-expected ] [ word>gc-info ] bi same-gc-info?
 114 ] unit-test
 115
 116 { t } [
 117     \ opencl:cl-queue-kernel
 118     [ word>gc-info-expected ] [ word>gc-info ] bi same-gc-info?
 119 ] unit-test
 120
 121 { t } [
 122     \ crypto.aes.utils:bytes>words
 123     [ word>gc-info-expected ] [ word>gc-info ] bi same-gc-info?
 124 ] unit-test
 125
 126 { t } [
 127     \ cpu.x86.features.private:(sse-version)
 128     [ word>gc-info-expected ] [ word>gc-info ] bi same-gc-info?
 129 ] unit-test
 130
 131 ! #1436
 132 { t } [
 133     \ gtk-samples.opengl:opengl-main
 134     [ word>gc-info-expected ] [ word>gc-info ] bi same-gc-info?
 135 ] unit-test
 136
 137 ! Ensure deterministic gc map generation.
 138 : recompile-word>gc-info ( word -- gc-info )
 139     [ 1array compile ] keep word>gc-info ;
 140
 141 : deterministic-gc-info? ( word -- ? )
 142     20 swap '[
 143         _ recompile-word>gc-info struct-slot-values
 144         dup last 0 = [ drop f ] when
 145     ] replicate all-equal? ;
 146
 147 { t } [
 148     \ opencl:cl-queue-kernel deterministic-gc-info?
 149 ] unit-test