factor/basis/threads/threads-tests.factor

105 lines
2.5 KiB
Factor
Raw Normal View History

USING: io memory namespaces tools.test threads threads.private kernel
2008-04-27 04:16:12 -04:00
concurrency.combinators concurrency.promises locals math
words calendar sequences fry ;
2008-03-01 17:00:45 -05:00
IN: threads.tests
2008-02-18 06:07:40 -05:00
! Bug #1319
! The start-context-and-delete primitive calls reset_context which
! causes reads to uninitialized locations in the data segment if it
! gc:s
TUPLE: tup1 a ;
! This word attempts to fill the nursery so that there is less than 48
! bytes of free space in it. The constant used to fill is volatile but
! should work on 64 bit.
: fill-nursery ( -- obj )
minor-gc 48074 [ tup1 new ] replicate ;
: do-reset-context ( -- val )
! "main running" print flush
[ "a" print ] "foo1" spawn drop
[ "b" print ] "foo2" spawn drop
[ "c" print ] "foo3"
[ fill-nursery ] 2dip
spawn drop
0 seconds sleep ;
{ 48074 } [
do-reset-context length
] unit-test
2008-02-18 06:07:40 -05:00
3 "x" set
2008-05-09 18:14:26 -04:00
[ 2 "x" set ] "Test" spawn drop
{ 2 } [ yield "x" get ] unit-test
{ } [ [ flush ] "flush test" spawn drop flush ] unit-test
{ } [ [ "Errors, errors" throw ] "error test" spawn drop ] unit-test
2008-02-18 06:07:40 -05:00
yield
{ } [ 0.3 sleep ] unit-test
2008-02-18 06:07:40 -05:00
[ "hey" sleep ] must-fail
{ 3 } [ 3 self resume-with "Test suspend" suspend ] unit-test
{ f } [ f get-global ] unit-test
2008-04-17 06:16:28 -04:00
{ { 0 3 6 9 12 15 18 21 24 27 } } [
10 <iota> [
2008-04-17 06:16:28 -04:00
0 "i" tset
[
"i" [ yield 3 + ] tchange
] times yield
"i" tget
] parallel-map
] unit-test
2008-04-27 04:16:12 -04:00
2009-04-17 15:44:08 -04:00
:: spawn-namespace-test ( -- ? )
2009-10-27 22:50:31 -04:00
<promise> :> p gensym :> g
2012-07-19 16:55:34 -04:00
g "x" [
2009-10-27 22:50:31 -04:00
[ "x" get p fulfill ] "B" spawn drop
2012-07-19 16:55:34 -04:00
] with-variable
2009-10-27 22:50:31 -04:00
p ?promise g eq? ;
2008-04-27 04:16:12 -04:00
{ t } [ spawn-namespace-test ] unit-test
2008-07-29 19:44:44 -04:00
[ "a" [ 1 1 + ] spawn 100 sleep ] must-fail
{ } [ 0.1 seconds sleep ] unit-test
2010-03-28 12:33:41 -04:00
! Test thread-local variables
<promise> "p" set
5 "x" tset
{ 5 } [ "x" tget ] unit-test
2010-03-28 12:33:41 -04:00
{ } [ "x" [ 1 + ] tchange ] unit-test
2010-03-28 12:33:41 -04:00
{ 6 } [ "x" tget ] unit-test
2010-03-28 12:33:41 -04:00
! Are they truly thread-local?
[ "x" tget "p" get fulfill ] in-thread
{ f } [ "p" get ?promise ] unit-test
! Test system traps inside threads
{ } [ [ dup ] in-thread yield ] unit-test
! The start-context-and-delete primitive wasn't rewinding the
! callstack properly.
! This got fixed for x86-64 but the problem remained on x86-32.
! The unit test asserts that the callstack is empty from the
! quotation passed to start-context-and-delete.
{ 3 } [
<promise> [
'[
_ [
2015-08-13 13:16:10 -04:00
[ get-callstack swap fulfill stop ] start-context-and-delete
] start-context-and-delete
] in-thread
2011-12-14 16:45:53 -05:00
] [ ?promise callstack>array length ] bi
] unit-test