compiler.tests.alien: use the with-callback combinator to plug the memory leaks in the tests
Björn Lindqvist
John Benediktsson
parent
65e460cf57
commit
cb83f3b39b
|
|
@ -1,6 +1,6 @@
|
|||
USING: accessors alien alien.c-types alien.libraries
|
||||
alien.syntax arrays classes.struct combinators
|
||||
compiler continuations destructors effects fry generalizations io
|
||||
compiler continuations destructors effects generalizations io
|
||||
io.backend io.pathnames io.streams.string kernel
|
||||
math memory namespaces namespaces.private parser
|
||||
quotations sequences specialized-arrays stack-checker
|
||||
|
|
@ -13,9 +13,6 @@ SPECIALIZED-ARRAY: float
|
|||
SPECIALIZED-ARRAY: char
|
||||
IN: compiler.tests.alien
|
||||
|
||||
: unit-test-with-destructors ( exp quot -- )
|
||||
'[ _ with-destructors ] unit-test ; inline
|
||||
|
||||
! Make sure that invalid inputs don't pass the stack checker
|
||||
[ [ void { } "cdecl" alien-indirect ] infer ] must-fail
|
||||
[ [ "void" { } cdecl alien-indirect ] infer ] must-fail
|
||||
|
|
@ -341,65 +338,67 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
|
|||
: callback-throws ( -- x )
|
||||
int { } cdecl [ "Hi" throw ] alien-callback ;
|
||||
|
||||
{ t } [ callback-throws alien? ] unit-test-with-destructors
|
||||
{ t } [
|
||||
callback-throws [ alien? ] with-callback
|
||||
] unit-test
|
||||
|
||||
: callback-1 ( -- callback ) void { } cdecl [ ] alien-callback ;
|
||||
|
||||
[ 0 1 ] [ [ callback-1 ] infer [ in>> length ] [ out>> length ] bi ] unit-test
|
||||
|
||||
{ t } [ callback-1 alien? ] unit-test-with-destructors
|
||||
{ t } [ callback-1 [ alien? ] with-callback ] unit-test
|
||||
|
||||
: callback_test_1 ( ptr -- ) void { } cdecl alien-indirect ;
|
||||
|
||||
{ } [ callback-1 callback_test_1 ] unit-test-with-destructors
|
||||
{ } [ callback-1 [ callback_test_1 ] with-callback ] unit-test
|
||||
|
||||
: callback-2 ( -- callback ) void { } cdecl [ [ 5 throw ] ignore-errors ] alien-callback ;
|
||||
|
||||
{ } [ callback-2 callback_test_1 ] unit-test-with-destructors
|
||||
{ } [ callback-2 [ callback_test_1 ] with-callback ] unit-test
|
||||
|
||||
: callback-3 ( -- callback ) void { } cdecl [ 5 "x" set ] alien-callback ;
|
||||
|
||||
{ t 3 5 } [
|
||||
[
|
||||
namestack*
|
||||
3 "x" set callback-3 callback_test_1
|
||||
3 "x" set callback-3 [ callback_test_1 ] with-callback
|
||||
namestack* eq?
|
||||
"x" get "x" get-global
|
||||
] with-scope
|
||||
] unit-test-with-destructors
|
||||
] unit-test
|
||||
|
||||
: callback-5 ( -- callback )
|
||||
void { } cdecl [ gc ] alien-callback ;
|
||||
|
||||
{ "testing" } [
|
||||
"testing" callback-5 callback_test_1
|
||||
] unit-test-with-destructors
|
||||
"testing" callback-5 [ callback_test_1 ] with-callback
|
||||
] unit-test
|
||||
|
||||
: callback-5b ( -- callback )
|
||||
void { } cdecl [ compact-gc ] alien-callback ;
|
||||
|
||||
[ "testing" ] [
|
||||
"testing" callback-5b callback_test_1
|
||||
] unit-test-with-destructors
|
||||
"testing" callback-5b [ callback_test_1 ] with-callback
|
||||
] unit-test
|
||||
|
||||
: callback-6 ( -- callback )
|
||||
void { } cdecl [ [ continue ] callcc0 ] alien-callback ;
|
||||
|
||||
[ 1 2 3 ] [
|
||||
callback-6 callback_test_1 1 2 3
|
||||
] unit-test-with-destructors
|
||||
callback-6 [ callback_test_1 1 2 3 ] with-callback
|
||||
] unit-test
|
||||
|
||||
: callback-7 ( -- callback )
|
||||
void { } cdecl [ 1000000 sleep ] alien-callback ;
|
||||
|
||||
[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test-with-destructors
|
||||
[ 1 2 3 ] [ callback-7 [ callback_test_1 1 2 3 ] with-callback ] unit-test
|
||||
|
||||
[ f ] [ namespace global eq? ] unit-test
|
||||
|
||||
: callback-8 ( -- callback )
|
||||
void { } cdecl [ [ ] in-thread yield ] alien-callback ;
|
||||
|
||||
[ ] [ callback-8 callback_test_1 ] unit-test-with-destructors
|
||||
[ ] [ callback-8 [ callback_test_1 ] with-callback ] unit-test
|
||||
|
||||
: callback-9 ( -- callback )
|
||||
int { int int int } cdecl [
|
||||
|
|
@ -412,9 +411,9 @@ FUNCTION: void ffi_test_36_point_5 ( ) ;
|
|||
|
||||
FUNCTION: int ffi_test_37 ( void* func ) ;
|
||||
|
||||
[ 1 ] [ callback-9 ffi_test_37 ] unit-test-with-destructors
|
||||
[ 1 ] [ callback-9 [ ffi_test_37 ] with-callback ] unit-test
|
||||
|
||||
[ 7 ] [ callback-9 ffi_test_37 ] unit-test-with-destructors
|
||||
[ 7 ] [ callback-9 [ ffi_test_37 ] with-callback ] unit-test
|
||||
|
||||
STRUCT: test_struct_13
|
||||
{ x1 float }
|
||||
|
|
@ -470,9 +469,11 @@ STRUCT: double-rect
|
|||
|
||||
{ byte-array 1.0 2.0 3.0 4.0 } [
|
||||
1.0 2.0 3.0 4.0 <double-rect>
|
||||
double-rect-callback double-rect-test
|
||||
[ >c-ptr class-of ] [ >double-rect< ] bi
|
||||
] unit-test-with-destructors
|
||||
double-rect-callback [
|
||||
double-rect-test
|
||||
[ >c-ptr class-of ] [ >double-rect< ] bi
|
||||
] with-callback
|
||||
] unit-test
|
||||
|
||||
STRUCT: test_struct_14
|
||||
{ x1 double }
|
||||
|
|
@ -496,9 +497,10 @@ FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
|
|||
test_struct_14 { double double } cdecl alien-indirect ;
|
||||
|
||||
{ 1.0 2.0 } [
|
||||
1.0 2.0 callback-10 callback-10-test
|
||||
[ x1>> ] [ x2>> ] bi
|
||||
] unit-test-with-destructors
|
||||
1.0 2.0 callback-10 [
|
||||
callback-10-test [ x1>> ] [ x2>> ] bi
|
||||
] with-callback
|
||||
] unit-test
|
||||
|
||||
FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
|
||||
|
||||
|
|
@ -519,9 +521,10 @@ FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
|
|||
test-struct-12 { int double } cdecl alien-indirect ;
|
||||
|
||||
{ 1 2.0 } [
|
||||
1 2.0 callback-11 callback-11-test
|
||||
[ a>> ] [ x>> ] bi
|
||||
] unit-test-with-destructors
|
||||
1 2.0 callback-11 [
|
||||
callback-11-test [ a>> ] [ x>> ] bi
|
||||
] with-callback
|
||||
] unit-test
|
||||
|
||||
STRUCT: test_struct_15
|
||||
{ x float }
|
||||
|
|
@ -543,8 +546,10 @@ FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
|
|||
test_struct_15 { float float } cdecl alien-indirect ;
|
||||
|
||||
[ 1.0 2.0 ] [
|
||||
1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
|
||||
] unit-test-with-destructors
|
||||
1.0 2.0 callback-12 [
|
||||
callback-12-test [ x>> ] [ y>> ] bi
|
||||
] with-callback
|
||||
] unit-test
|
||||
|
||||
STRUCT: test_struct_16
|
||||
{ x float }
|
||||
|
|
@ -566,9 +571,10 @@ FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
|
|||
test_struct_16 { float int } cdecl alien-indirect ;
|
||||
|
||||
{ 1.0 2 } [
|
||||
1.0 2 callback-13 callback-13-test
|
||||
[ x>> ] [ a>> ] bi
|
||||
] unit-test-with-destructors
|
||||
1.0 2 callback-13 [
|
||||
callback-13-test [ x>> ] [ a>> ] bi
|
||||
] with-callback
|
||||
] unit-test
|
||||
|
||||
FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
|
||||
|
||||
|
|
@ -624,13 +630,13 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
|
|||
|
||||
<promise> "p" set
|
||||
[
|
||||
[
|
||||
thread-callback-1 thread-callback-invoker "p" get fulfill
|
||||
] with-destructors
|
||||
thread-callback-1 [
|
||||
thread-callback-invoker
|
||||
] with-callback "p" get fulfill
|
||||
] in-thread
|
||||
{ 200 } [
|
||||
thread-callback-2 thread-callback-invoker
|
||||
] unit-test-with-destructors
|
||||
thread-callback-2 [ thread-callback-invoker ] with-callback
|
||||
] unit-test
|
||||
[ 100 ] [ "p" get ?promise ] unit-test
|
||||
|
||||
! More alien-assembly tests are in cpu.* vocabs
|
||||
|
|
@ -779,28 +785,32 @@ mingw? [
|
|||
[ [ drop + ] [ - nip ] 3bi test-struct-11 <struct-boa> ] alien-callback ;
|
||||
|
||||
{ 8 } [
|
||||
3 4 fastcall-ii-callback fastcall-ii-indirect
|
||||
] unit-test-with-destructors
|
||||
3 4 fastcall-ii-callback [ fastcall-ii-indirect ] with-callback
|
||||
] unit-test
|
||||
|
||||
[ 13 ] [
|
||||
3 4 5 fastcall-iii-callback fastcall-iii-indirect
|
||||
] unit-test-with-destructors
|
||||
3 4 5 fastcall-iii-callback [ fastcall-iii-indirect ] with-callback
|
||||
] unit-test
|
||||
|
||||
[ 13 ] [
|
||||
3 4.0 5 fastcall-ifi-callback fastcall-ifi-indirect
|
||||
] unit-test-with-destructors
|
||||
3 4.0 5 fastcall-ifi-callback [ fastcall-ifi-indirect ] with-callback
|
||||
] unit-test
|
||||
|
||||
[ 19 ] [
|
||||
3 4.0 5 6 fastcall-ifii-callback fastcall-ifii-indirect
|
||||
] unit-test-with-destructors
|
||||
3 4.0 5 6 fastcall-ifii-callback [ fastcall-ifii-indirect ] with-callback
|
||||
] unit-test
|
||||
|
||||
[ S{ test-struct-11 f 7 -1 } ] [
|
||||
3 4 fastcall-struct-return-ii-callback fastcall-struct-return-ii-indirect
|
||||
] unit-test-with-destructors
|
||||
3 4 fastcall-struct-return-ii-callback [
|
||||
fastcall-struct-return-ii-indirect
|
||||
] with-callback
|
||||
] unit-test
|
||||
|
||||
[ S{ test-struct-11 f 7 -3 } ] [
|
||||
3 4 7 fastcall-struct-return-iii-callback fastcall-struct-return-iii-indirect
|
||||
] unit-test-with-destructors
|
||||
3 4 7 fastcall-struct-return-iii-callback [
|
||||
fastcall-struct-return-iii-indirect
|
||||
] with-callback
|
||||
] unit-test
|
||||
|
||||
: x64-regression-1 ( -- c )
|
||||
int { int int int int int } cdecl [ + + + + ] alien-callback ;
|
||||
|
|
@ -809,11 +819,13 @@ mingw? [
|
|||
int { int int int int int } cdecl alien-indirect ; inline
|
||||
|
||||
[ 661 ] [
|
||||
100 500 50 10 1 x64-regression-1 x64-regression-2
|
||||
] unit-test-with-destructors
|
||||
100 500 50 10 1 x64-regression-1 [ x64-regression-2 ] with-callback
|
||||
] unit-test
|
||||
|
||||
! Stack allocation
|
||||
: blah ( -- x ) { RECT } [ 1.5 >>x 2.0 >>y [ x>> ] [ y>> ] bi * >fixnum ] with-scoped-allocation ;
|
||||
: blah ( -- x ) { RECT } [
|
||||
1.5 >>x 2.0 >>y [ x>> ] [ y>> ] bi * >fixnum
|
||||
] with-scoped-allocation ;
|
||||
|
||||
[ 3 ] [ blah ] unit-test
|
||||
|
||||
|
|
@ -845,8 +857,8 @@ mingw? [
|
|||
] with-out-parameters ;
|
||||
|
||||
[ 12 ] [
|
||||
6 out-param-callback out-param-indirect
|
||||
] unit-test-with-destructors
|
||||
6 out-param-callback [ out-param-indirect ] with-callback
|
||||
] unit-test
|
||||
|
||||
! Alias analysis regression
|
||||
: aa-callback-1 ( -- c )
|
||||
|
|
@ -860,10 +872,11 @@ TUPLE: some-tuple x ;
|
|||
[ T{ some-tuple f 5.0 } ] [
|
||||
[
|
||||
some-tuple new
|
||||
aa-callback-1
|
||||
aa-indirect-1 >>x
|
||||
aa-callback-1 [
|
||||
aa-indirect-1
|
||||
] with-callback >>x
|
||||
] compile-call
|
||||
] unit-test-with-destructors
|
||||
] unit-test
|
||||
|
||||
! GC maps regression
|
||||
: anton's-regression ( -- )
|
||||
|
|
|
|||
Loading…
Reference in New Issue