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.short-circuit compiler compiler.cfg
   3 compiler.cfg.debugger compiler.cfg.instructions
   4 compiler.cfg.linearization compiler.codegen.gc-maps compiler.units fry
   5 generic grouping io io.encodings.binary io.streams.byte-array kernel
   6 math namespaces random sequences system tools.image-analyzer.gc-info
   7 tools.image-analyzer.utils tools.test vm vocabs words ;
   8 IN: tools.image-analyzer.gc-info.tests
   9 QUALIFIED: cpu.x86.features.private
  10 QUALIFIED: crypto.aes.utils
  11 QUALIFIED: effects
  12 QUALIFIED: gtk-samples.opengl
  13 QUALIFIED: opencl
  14
  15 : normal? ( word -- ? )
  16     { [ generic? ] [ primitive? ] [ inline? ] [ no-compile? ] } 1|| not ;
  17
  18 : word>gc-info ( word -- gc-info )
  19     word>byte-array binary <byte-reader> <backwards-reader> [
  20         gc-info read-struct-safe
  21     ] with-input-stream ;
  22
  23 : cfg>gc-maps ( cfg -- gc-maps )
  24     cfg>insns [ gc-map-insn? ] filter [ gc-map>> ] map
  25     [ gc-map-needed? ] filter ;
  26
  27 : tally-gc-maps ( gc-maps -- seq/f )
  28     [ f ] [
  29         [ [ gc-root-offsets ] map largest-spill-slot ]
  30         [ [ derived-root-offsets ] map [ keys ] map largest-spill-slot ]
  31         [ length ] tri 3array
  32     ] if-empty ;
  33
  34 ! Like word>gc-info but uses the compiler
  35 : word>gc-info-expected ( word -- seq/f )
  36     test-regs first [ cfg set ] [ cfg>gc-maps tally-gc-maps ] bi ;
  37
  38 ! Handle f f as input. Deferred words don't have any gc-info. See #1394.
  39 : same-gc-info? ( compiler-gc-info/f gc-info/f -- ? )
  40     2dup = [
  41         2drop t
  42     ] [
  43         [ struct-slot-values = ]
  44         [ [ not ] dip return-address-count>> 0 = and ] 2bi or
  45     ] if ;
  46
  47 : base-pointer-groups-expected ( word -- seq )
  48     test-regs first cfg>gc-maps [ derived-root-offsets { } like ] { } map-as ;
  49
  50 : base-pointer-groups-decoded ( word -- seq )
  51     word>gc-maps [
  52         second second [ swap 2array ] map-index
  53         [ -1 = ] reject-values
  54     ] map ;
  55
  56 ! byte-array>bit-array
  57 {
  58     ?{
  59         t t t t f t t t
  60         t f f f f f f f
  61     }
  62 } [
  63     B{ 239 1 } byte-array>bit-array
  64 ] unit-test
  65
  66 { ?{ t t t t t t t t } } [ B{ 255 } byte-array>bit-array ] unit-test
  67
  68 ! word>gc-maps
  69 { f } [
  70     \ effects:<effect> word>gc-maps empty?
  71 ] unit-test
  72
  73 cpu x86.64? [
  74     os windows? [
  75         ! The difference is because Windows stack references are
  76         ! longer because of the home space.
  77         {
  78             { 156 { ?{ f f f f f t t t t } { } } }
  79         }
  80     ] [
  81         {
  82             { 155 { ?{ f t t t t } { } } }
  83         }
  84     ] if
  85     [
  86         \ effects:<effect> word>gc-maps first
  87     ] unit-test
  88 ] when
  89
  90 { f } [
  91     \ + word>gc-maps empty?
  92 ] unit-test
  93
  94 { { } } [
  95     \ word>gc-maps word>gc-maps
  96 ] unit-test
  97
  98 ! Big test
  99 { { } } [
 100     all-words [ normal? ] filter 50 sample
 101     [ [ word>gc-info-expected ] [ word>gc-info ] bi same-gc-info? ] reject
 102 ] unit-test
 103
 104 ! Originally from llvm.types, but llvm moved to unmaintained
 105 TYPEDEF: void* LLVMTypeRef
 106 TYPEDEF: void* LLVMTypeHandleRef
 107 FUNCTION: LLVMTypeRef LLVMResolveTypeHandle ( LLVMTypeHandleRef TypeHandle )
 108 FUNCTION: LLVMTypeHandleRef LLVMCreateTypeHandle ( LLVMTypeRef PotentiallyAbstractTy )
 109 FUNCTION: void LLVMRefineType ( LLVMTypeRef AbstractTy, LLVMTypeRef ConcreteTy )
 110 FUNCTION: void LLVMDisposeTypeHandle ( LLVMTypeHandleRef TypeHandle )
 111
 112 : resolve-types ( typeref typeref -- typeref )
 113     over LLVMCreateTypeHandle [ LLVMRefineType ] dip
 114     [ LLVMResolveTypeHandle ] keep LLVMDisposeTypeHandle ;
 115
 116 ! base-pointer-groups
 117 { t } [
 118 \ resolve-types
 119     [ base-pointer-groups-expected ] [ base-pointer-groups-decoded ] bi =
 120 ] unit-test
 121
 122 ! Tough words #1227
 123 { t } [
 124     \ resolve-types
 125     [ word>gc-info-expected ] [ word>gc-info ] bi same-gc-info?
 126 ] unit-test
 127
 128 { t } [
 129     \ opencl:cl-queue-kernel
 130     [ word>gc-info-expected ] [ word>gc-info ] bi same-gc-info?
 131 ] unit-test
 132
 133 { t } [
 134     \ crypto.aes.utils:bytes>words
 135     [ word>gc-info-expected ] [ word>gc-info ] bi same-gc-info?
 136 ] unit-test
 137
 138 { t } [
 139     \ cpu.x86.features.private:(sse-version)
 140     [ word>gc-info-expected ] [ word>gc-info ] bi same-gc-info?
 141 ] unit-test
 142
 143 ! #1436
 144 { t } [
 145     \ gtk-samples.opengl:opengl-main
 146     [ word>gc-info-expected ] [ word>gc-info ] bi same-gc-info?
 147 ] unit-test
 148
 149 ! Ensure deterministic gc map generation.
 150 : recompile-word>gc-info ( word -- gc-info )
 151     [ 1array compile ] keep word>gc-info ;
 152
 153 : deterministic-gc-info? ( word -- ? )
 154     20 swap '[
 155         _ recompile-word>gc-info struct-slot-values
 156         dup last 0 = [ drop f ] when
 157     ] replicate all-equal? ;
 158
 159 { t } [
 160     \ opencl:cl-queue-kernel deterministic-gc-info?
 161 ] unit-test
 162
 163
 164
 165 ! TODO: try on 32 bit \ feedback-format: