From be372831f5819c14f5e9bd93b7a4a5717b633c28 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Lindqvist?= Date: Mon, 29 Sep 2014 14:26:08 +0200 Subject: [PATCH] compiler.tests.alien: wrap all callback tests in special unit-test-with-destructor blocks, that way they dont leak memory in the callback heap --- basis/compiler/tests/alien.factor | 102 ++++++++++++++++++------------ 1 file changed, 63 insertions(+), 39 deletions(-) diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 46fd171a44..efda89adaa 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -1,6 +1,6 @@ USING: accessors alien alien.c-types alien.libraries 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 math memory namespaces namespaces.private parser quotations sequences specialized-arrays stack-checker @@ -13,6 +13,9 @@ 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 @@ -338,63 +341,65 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ; : callback-throws ( -- x ) 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 ; [ 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-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_test_1 ] unit-test +{ } [ callback-2 callback_test_1 ] unit-test-with-destructors : callback-3 ( -- callback ) void { } cdecl [ 5 "x" set ] alien-callback ; -[ t 3 5 ] [ +{ t 3 5 } [ [ namestack* 3 "x" set callback-3 callback_test_1 namestack* eq? "x" get "x" get-global ] with-scope -] unit-test +] unit-test-with-destructors : callback-5 ( -- callback ) void { } cdecl [ gc ] alien-callback ; -[ "testing" ] [ +{ "testing" } [ "testing" callback-5 callback_test_1 -] unit-test +] unit-test-with-destructors : callback-5b ( -- callback ) void { } cdecl [ compact-gc ] alien-callback ; [ "testing" ] [ "testing" callback-5b callback_test_1 -] unit-test +] unit-test-with-destructors : callback-6 ( -- 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 ) 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 : callback-8 ( -- 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 ) int { int int int } cdecl [ @@ -407,9 +412,9 @@ FUNCTION: void ffi_test_36_point_5 ( ) ; 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 { x1 float } @@ -463,12 +468,11 @@ STRUCT: double-rect void { void* void* double-rect } cdecl alien-indirect "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-callback double-rect-test [ >c-ptr class-of ] [ >double-rect< ] bi -] unit-test +] unit-test-with-destructors STRUCT: test_struct_14 { x1 double } @@ -491,10 +495,10 @@ FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ; : callback-10-test ( x1 x2 callback -- result ) 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 [ x1>> ] [ x2>> ] bi -] unit-test +] unit-test-with-destructors 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 ) test-struct-12 { int double } cdecl alien-indirect ; -[ 1 2.0 ] [ +{ 1 2.0 } [ 1 2.0 callback-11 callback-11-test [ a>> ] [ x>> ] bi -] unit-test +] unit-test-with-destructors STRUCT: test_struct_15 { 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 callback-12 callback-12-test [ x>> ] [ y>> ] bi -] unit-test +] unit-test-with-destructors STRUCT: test_struct_16 { x float } @@ -561,10 +565,10 @@ FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ; : callback-13-test ( x1 x2 callback -- result ) test_struct_16 { float int } cdecl alien-indirect ; -[ 1.0 2 ] [ +{ 1.0 2 } [ 1.0 2 callback-13 callback-13-test [ x>> ] [ a>> ] bi -] unit-test +] unit-test-with-destructors 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 ; "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 ! More alien-assembly tests are in cpu.* vocabs @@ -644,7 +654,7 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ; [ int "f-fastcall" "ffi_test_51" { int int int } alien-invoke ] 3dip int "f-fastcall" "ffi_test_51" { int int int } alien-invoke gc ; - + [ 4 ] [ 3 ffi_test_49 ] unit-test [ 8 ] [ 3 4 ffi_test_50 ] unit-test [ 13 ] [ 3 4 5 ffi_test_51 ] unit-test @@ -768,19 +778,29 @@ mingw? [ test-struct-11 { int int int } fastcall [ [ drop + ] [ - nip ] 3bi test-struct-11 ] 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 } ] -[ 3 4 fastcall-struct-return-ii-callback fastcall-struct-return-ii-indirect ] 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 -[ S{ test-struct-11 f 7 -3 } ] -[ 3 4 7 fastcall-struct-return-iii-callback fastcall-struct-return-iii-indirect ] 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 : x64-regression-1 ( -- c ) int { int int int int int } cdecl [ + + + + ] alien-callback ; @@ -788,7 +808,9 @@ mingw? [ : x64-regression-2 ( x x x x x c -- y ) 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 : blah ( -- x ) { RECT } [ 1.5 >>x 2.0 >>y [ x>> ] [ y>> ] bi * >fixnum ] with-scoped-allocation ; @@ -822,7 +844,9 @@ mingw? [ alien-indirect ] 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 : aa-callback-1 ( -- c ) @@ -839,7 +863,7 @@ TUPLE: some-tuple x ; aa-callback-1 aa-indirect-1 >>x ] compile-call -] unit-test +] unit-test-with-destructors ! GC maps regression : anton's-regression ( -- )