basis/compiler/cfg/builder/alien/alien-tests.factor

   1 USING: accessors alien alien.c-types alien.strings assocs compiler.cfg
   2 compiler.cfg.builder compiler.cfg.builder.alien
   3 compiler.cfg.builder.alien.params compiler.cfg.builder.blocks
   4 compiler.cfg.instructions compiler.cfg.registers compiler.cfg.stacks
   5 compiler.errors compiler.test compiler.tree.builder
   6 compiler.tree.optimizer cpu.architecture cpu.x86.assembler
   7 cpu.x86.assembler.operands kernel literals make namespaces sequences
   8 stack-checker.alien system tools.test words ;
   9 IN: compiler.cfg.builder.alien.tests
  10
  11 : dummy-assembly ( -- ass )
  12     int { } cdecl [
  13         EAX 33 MOV
  14     ] alien-assembly ;
  15
  16 { t } [
  17     <basic-block> dup set-basic-block dup
  18     \ dummy-assembly build-tree optimize-tree first
  19     [ emit-node ] V{ } make drop eq?
  20 ] cfg-unit-test
  21
  22 : dummy-callback ( -- cb )
  23     void { } cdecl [ ] alien-callback ;
  24
  25 { 2 t } [
  26     \ dummy-callback build-tree optimize-tree gensym build-cfg
  27     [ length ] [ second frame-pointer?>> ] bi
  28 ] unit-test
  29
  30 {
  31     V{
  32         T{ ##load-reference { dst 1 } { obj t } }
  33         T{ ##load-integer { dst 2 } { val 3 } }
  34         T{ ##copy { dst 4 } { src 1 } { rep any-rep } }
  35         T{ ##copy { dst 3 } { src 2 } { rep any-rep } }
  36         T{ ##inc { loc D: 2 } }
  37         T{ ##branch }
  38     }
  39 } [
  40     <basic-block> dup set-basic-block
  41     \ dummy-callback build-tree optimize-tree 3 swap nth child>>
  42     [ emit-callback-body drop ] V{ } make
  43 ] cfg-unit-test
  44
  45 ! caller-linkage
  46 ${
  47     "malloc"
  48     os windows? "msvcrt.dll" f ?
  49 } [
  50     f f cdecl f "libc" "malloc" alien-invoke-params boa
  51     caller-linkage
  52     dup [ path>> alien>native-string ] when
  53 ] unit-test
  54
  55 SYMBOL: foo
  56
  57 { t "fdkjlsdflfd" } [
  58     begin-stack-analysis \ foo f begin-cfg drop
  59     f f cdecl f f "fdkjlsdflfd" alien-invoke-params boa
  60     caller-linkage 2drop
  61     linkage-errors get foo of error>>
  62     [ no-such-symbol? ] [ name>> ] bi
  63 ] unit-test
  64
  65 ! caller-parameters
  66 cpu x86.64? [
  67     ${
  68         os windows? [
  69             V{
  70                 { 1 int-rep RCX }
  71                 { 2 float-rep XMM1 }
  72                 { 3 double-rep XMM2 }
  73                 { 4 int-rep R9 }
  74             }
  75         ] [
  76             V{
  77                 { 1 int-rep RDI }
  78                 { 2 float-rep XMM0 }
  79                 { 3 double-rep XMM1 }
  80                 { 4 int-rep RSI }
  81             }
  82         ] if
  83         V{ }
  84     } [
  85         void { int float double char } cdecl f f "func"
  86         alien-invoke-params boa caller-parameters
  87     ] cfg-unit-test
  88 ] when
  89
  90 ! caller-stack-cleanup
  91 { 0 } [
  92     alien-node-params new long >>return cdecl >>abi 25
  93     caller-stack-cleanup
  94 ] unit-test
  95
  96 ! check-dlsym
  97 { } [
  98     "malloc" f check-dlsym
  99 ] unit-test
 100
 101 ! prepare-caller-return
 102 ${
 103     cpu x86.32? { { 1 int-rep EAX } } { { 1 int-rep RAX } } ?
 104     cpu x86.32? { { 2 double-rep ST0 } } { { 2 double-rep XMM0 } } ?
 105 } [
 106     T{ alien-invoke-params { return int } } prepare-caller-return
 107     T{ alien-invoke-params { return double } } prepare-caller-return
 108 ] cfg-unit-test
 109
 110 ! unbox-parameters
 111
 112 ! unboxing ints is only needed on 32bit archs
 113 cpu x86.32?
 114 {
 115     { 2 4 }
 116     { { int-rep f f } { int-rep f f } }
 117     V{
 118         T{ ##unbox-any-c-ptr { dst 2 } { src 1 } }
 119         T{ ##unbox
 120            { dst 4 }
 121            { src 3 }
 122            { unboxer "to_fixnum" }
 123            { rep int-rep }
 124         }
 125     }
 126 }
 127 {
 128     { 2 3 }
 129     { { int-rep f f } { int-rep f f } }
 130     V{ T{ ##unbox-any-c-ptr { dst 2 } { src 1 } } }
 131 } ? [
 132     [ { c-string int } unbox-parameters ] V{ } make
 133 ] cfg-unit-test
 134
 135 ! with-param-regs*
 136 {
 137     V{ }
 138     V{ }
 139     f f
 140 } [
 141     cdecl [ ] with-param-regs
 142     reg-values get stack-values get
 143 ] unit-test