steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

compiler.tests.alien: wrap all callback tests in special 

unit-test-with-destructor blocks, that way they dont leak memory in the
callback heap
db4
Björn Lindqvist 2014-09-29 14:26:08 +02:00 committed by John Benediktsson
parent 5cf8c7cfba
commit be372831f5
1 changed files with 63 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

100
basis/compiler/tests/alien.factor
View File

@ -1,6 +1,6 @@
USING: accessors alien alien.c-types alien.libraries USING: accessors alien alien.c-types alien.libraries
alien.syntax arrays classes.struct combinators alien.syntax arrays classes.struct combinators
compiler continuations effects generalizations io compiler continuations destructors effects fry generalizations io
io.backend io.pathnames io.streams.string kernel io.backend io.pathnames io.streams.string kernel
math memory namespaces namespaces.private parser math memory namespaces namespaces.private parser
quotations sequences specialized-arrays stack-checker quotations sequences specialized-arrays stack-checker
@ -13,6 +13,9 @@ SPECIALIZED-ARRAY: float
SPECIALIZED-ARRAY: char SPECIALIZED-ARRAY: char
IN: compiler.tests.alien 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 ! 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
[ [ "void" { } cdecl alien-indirect ] infer ] must-fail [ [ "void" { } cdecl alien-indirect ] infer ] must-fail
@ -338,63 +341,65 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
: callback-throws ( -- x ) : callback-throws ( -- x )
int { } cdecl [ "Hi" throw ] alien-callback ; int { } cdecl [ "Hi" throw ] alien-callback ;
[ t ] [ callback-throws alien? ] unit-test { t } [ callback-throws alien? ] unit-test-with-destructors
: callback-1 ( -- callback ) void { } cdecl [ ] alien-callback ; : callback-1 ( -- callback ) void { } cdecl [ ] alien-callback ;
[ 0 1 ] [ [ callback-1 ] infer [ in>> length ] [ out>> length ] bi ] unit-test [ 0 1 ] [ [ callback-1 ] infer [ in>> length ] [ out>> length ] bi ] unit-test
[ t ] [ callback-1 alien? ] unit-test { t } [ callback-1 alien? ] unit-test-with-destructors
: callback_test_1 ( ptr -- ) void { } cdecl alien-indirect ; : callback_test_1 ( ptr -- ) void { } cdecl alien-indirect ;
[ ] [ callback-1 callback_test_1 ] unit-test { } [ callback-1 callback_test_1 ] unit-test-with-destructors
: callback-2 ( -- callback ) void { } cdecl [ [ 5 throw ] ignore-errors ] alien-callback ; : callback-2 ( -- callback ) void { } cdecl [ [ 5 throw ] ignore-errors ] alien-callback ;
[ ] [ callback-2 callback_test_1 ] unit-test { } [ callback-2 callback_test_1 ] unit-test-with-destructors
: callback-3 ( -- callback ) void { } cdecl [ 5 "x" set ] alien-callback ; : callback-3 ( -- callback ) void { } cdecl [ 5 "x" set ] alien-callback ;
[ t 3 5 ] [ { t 3 5 } [
[ [
namestack* namestack*
3 "x" set callback-3 callback_test_1 3 "x" set callback-3 callback_test_1
namestack* eq? namestack* eq?
"x" get "x" get-global "x" get "x" get-global
] with-scope ] with-scope
] unit-test ] unit-test-with-destructors
: callback-5 ( -- callback ) : callback-5 ( -- callback )
void { } cdecl [ gc ] alien-callback ; void { } cdecl [ gc ] alien-callback ;
[ "testing" ] [ { "testing" } [
"testing" callback-5 callback_test_1 "testing" callback-5 callback_test_1
] unit-test ] unit-test-with-destructors
: callback-5b ( -- callback ) : callback-5b ( -- callback )
void { } cdecl [ compact-gc ] alien-callback ; void { } cdecl [ compact-gc ] alien-callback ;
[ "testing" ] [ [ "testing" ] [
"testing" callback-5b callback_test_1 "testing" callback-5b callback_test_1
] unit-test ] unit-test-with-destructors
: callback-6 ( -- callback ) : callback-6 ( -- callback )
void { } cdecl [ [ continue ] callcc0 ] alien-callback ; void { } cdecl [ [ continue ] callcc0 ] alien-callback ;
[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test [ 1 2 3 ] [
callback-6 callback_test_1 1 2 3
] unit-test-with-destructors
: callback-7 ( -- callback ) : callback-7 ( -- callback )
void { } cdecl [ 1000000 sleep ] alien-callback ; void { } cdecl [ 1000000 sleep ] alien-callback ;
[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test [ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test-with-destructors
[ f ] [ namespace global eq? ] unit-test [ f ] [ namespace global eq? ] unit-test
: callback-8 ( -- callback ) : callback-8 ( -- callback )
void { } cdecl [ [ ] in-thread yield ] alien-callback ; void { } cdecl [ [ ] in-thread yield ] alien-callback ;
[ ] [ callback-8 callback_test_1 ] unit-test [ ] [ callback-8 callback_test_1 ] unit-test-with-destructors
: callback-9 ( -- callback ) : callback-9 ( -- callback )
int { int int int } cdecl [ int { int int int } cdecl [
@ -407,9 +412,9 @@ FUNCTION: void ffi_test_36_point_5 ( ) ;
FUNCTION: int ffi_test_37 ( void* func ) ; FUNCTION: int ffi_test_37 ( void* func ) ;
[ 1 ] [ callback-9 ffi_test_37 ] unit-test [ 1 ] [ callback-9 ffi_test_37 ] unit-test-with-destructors
[ 7 ] [ callback-9 ffi_test_37 ] unit-test [ 7 ] [ callback-9 ffi_test_37 ] unit-test-with-destructors
STRUCT: test_struct_13 STRUCT: test_struct_13
{ x1 float } { x1 float }
@ -463,12 +468,11 @@ STRUCT: double-rect
void { void* void* double-rect } cdecl alien-indirect void { void* void* double-rect } cdecl alien-indirect
"example" get-global ; "example" get-global ;
[ byte-array 1.0 2.0 3.0 4.0 ] { byte-array 1.0 2.0 3.0 4.0 } [
[
1.0 2.0 3.0 4.0 <double-rect> 1.0 2.0 3.0 4.0 <double-rect>
double-rect-callback double-rect-test double-rect-callback double-rect-test
[ >c-ptr class-of ] [ >double-rect< ] bi [ >c-ptr class-of ] [ >double-rect< ] bi
] unit-test ] unit-test-with-destructors
STRUCT: test_struct_14 STRUCT: test_struct_14
{ x1 double } { x1 double }
@ -491,10 +495,10 @@ FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
: callback-10-test ( x1 x2 callback -- result ) : callback-10-test ( x1 x2 callback -- result )
test_struct_14 { double double } cdecl alien-indirect ; test_struct_14 { double double } cdecl alien-indirect ;
[ 1.0 2.0 ] [ { 1.0 2.0 } [
1.0 2.0 callback-10 callback-10-test 1.0 2.0 callback-10 callback-10-test
[ x1>> ] [ x2>> ] bi [ x1>> ] [ x2>> ] bi
] unit-test ] unit-test-with-destructors
FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ; FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
@ -514,10 +518,10 @@ FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
: callback-11-test ( x1 x2 callback -- result ) : callback-11-test ( x1 x2 callback -- result )
test-struct-12 { int double } cdecl alien-indirect ; test-struct-12 { int double } cdecl alien-indirect ;
[ 1 2.0 ] [ { 1 2.0 } [
1 2.0 callback-11 callback-11-test 1 2.0 callback-11 callback-11-test
[ a>> ] [ x>> ] bi [ a>> ] [ x>> ] bi
] unit-test ] unit-test-with-destructors
STRUCT: test_struct_15 STRUCT: test_struct_15
{ x float } { x float }
@ -540,7 +544,7 @@ FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
[ 1.0 2.0 ] [ [ 1.0 2.0 ] [
1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi 1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
] unit-test ] unit-test-with-destructors
STRUCT: test_struct_16 STRUCT: test_struct_16
{ x float } { x float }
@ -561,10 +565,10 @@ FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
: callback-13-test ( x1 x2 callback -- result ) : callback-13-test ( x1 x2 callback -- result )
test_struct_16 { float int } cdecl alien-indirect ; test_struct_16 { float int } cdecl alien-indirect ;
[ 1.0 2 ] [ { 1.0 2 } [
1.0 2 callback-13 callback-13-test 1.0 2 callback-13 callback-13-test
[ x>> ] [ a>> ] bi [ x>> ] [ a>> ] bi
] unit-test ] unit-test-with-destructors
FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
@ -619,8 +623,14 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
int { } cdecl alien-indirect ; int { } cdecl alien-indirect ;
<promise> "p" set <promise> "p" set
[ thread-callback-1 thread-callback-invoker "p" get fulfill ] in-thread [
[ 200 ] [ thread-callback-2 thread-callback-invoker ] unit-test [
thread-callback-1 thread-callback-invoker "p" get fulfill
] with-destructors
] in-thread
{ 200 } [
thread-callback-2 thread-callback-invoker
] unit-test-with-destructors
[ 100 ] [ "p" get ?promise ] unit-test [ 100 ] [ "p" get ?promise ] unit-test
! More alien-assembly tests are in cpu.* vocabs ! More alien-assembly tests are in cpu.* vocabs
@ -768,19 +778,29 @@ mingw? [
test-struct-11 { int int int } fastcall test-struct-11 { int int int } fastcall
[ [ drop + ] [ - nip ] 3bi test-struct-11 <struct-boa> ] alien-callback ; [ [ drop + ] [ - nip ] 3bi test-struct-11 <struct-boa> ] alien-callback ;
[ 8 ] [ 3 4 fastcall-ii-callback fastcall-ii-indirect ] unit-test { 8 } [
3 4 fastcall-ii-callback fastcall-ii-indirect
] unit-test-with-destructors
[ 13 ] [ 3 4 5 fastcall-iii-callback fastcall-iii-indirect ] unit-test [ 13 ] [
3 4 5 fastcall-iii-callback fastcall-iii-indirect
] unit-test-with-destructors
[ 13 ] [ 3 4.0 5 fastcall-ifi-callback fastcall-ifi-indirect ] unit-test [ 13 ] [
3 4.0 5 fastcall-ifi-callback fastcall-ifi-indirect
] unit-test-with-destructors
[ 19 ] [ 3 4.0 5 6 fastcall-ifii-callback fastcall-ifii-indirect ] unit-test [ 19 ] [
3 4.0 5 6 fastcall-ifii-callback fastcall-ifii-indirect
] unit-test-with-destructors
[ S{ test-struct-11 f 7 -1 } ] [ S{ test-struct-11 f 7 -1 } ] [
[ 3 4 fastcall-struct-return-ii-callback fastcall-struct-return-ii-indirect ] unit-test 3 4 fastcall-struct-return-ii-callback fastcall-struct-return-ii-indirect
] unit-test-with-destructors
[ S{ test-struct-11 f 7 -3 } ] [ S{ test-struct-11 f 7 -3 } ] [
[ 3 4 7 fastcall-struct-return-iii-callback fastcall-struct-return-iii-indirect ] unit-test 3 4 7 fastcall-struct-return-iii-callback fastcall-struct-return-iii-indirect
] unit-test-with-destructors
: x64-regression-1 ( -- c ) : x64-regression-1 ( -- c )
int { int int int int int } cdecl [ + + + + ] alien-callback ; int { int int int int int } cdecl [ + + + + ] alien-callback ;
@ -788,7 +808,9 @@ mingw? [
: x64-regression-2 ( x x x x x c -- y ) : x64-regression-2 ( x x x x x c -- y )
int { int int int int int } cdecl alien-indirect ; inline int { int int int int int } cdecl alien-indirect ; inline
[ 661 ] [ 100 500 50 10 1 x64-regression-1 x64-regression-2 ] unit-test [ 661 ] [
100 500 50 10 1 x64-regression-1 x64-regression-2
] unit-test-with-destructors
! Stack allocation ! 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 ;
@ -822,7 +844,9 @@ mingw? [
alien-indirect alien-indirect
] with-out-parameters ; ] with-out-parameters ;
[ 12 ] [ 6 out-param-callback out-param-indirect ] unit-test [ 12 ] [
6 out-param-callback out-param-indirect
] unit-test-with-destructors
! Alias analysis regression ! Alias analysis regression
: aa-callback-1 ( -- c ) : aa-callback-1 ( -- c )
@ -839,7 +863,7 @@ TUPLE: some-tuple x ;
aa-callback-1 aa-callback-1
aa-indirect-1 >>x aa-indirect-1 >>x
] compile-call ] compile-call
] unit-test ] unit-test-with-destructors
! GC maps regression ! GC maps regression
: anton's-regression ( -- ) : anton's-regression ( -- )