201 lines
4.6 KiB
Factor
201 lines
4.6 KiB
Factor
IN: concurrency.locks.tests
|
|
USING: tools.test concurrency.locks concurrency.count-downs
|
|
concurrency.messaging concurrency.mailboxes locals kernel
|
|
threads sequences calendar accessors ;
|
|
|
|
:: lock-test-0 ( -- v )
|
|
[let | v [ V{ } clone ]
|
|
c [ 2 <count-down> ] |
|
|
|
|
[
|
|
yield
|
|
1 v push
|
|
yield
|
|
2 v push
|
|
c count-down
|
|
] "Lock test 1" spawn drop
|
|
|
|
[
|
|
yield
|
|
3 v push
|
|
yield
|
|
4 v push
|
|
c count-down
|
|
] "Lock test 2" spawn drop
|
|
|
|
c await
|
|
v
|
|
] ;
|
|
|
|
:: lock-test-1 ( -- v )
|
|
[let | v [ V{ } clone ]
|
|
l [ <lock> ]
|
|
c [ 2 <count-down> ] |
|
|
|
|
[
|
|
l [
|
|
yield
|
|
1 v push
|
|
yield
|
|
2 v push
|
|
] with-lock
|
|
c count-down
|
|
] "Lock test 1" spawn drop
|
|
|
|
[
|
|
l [
|
|
yield
|
|
3 v push
|
|
yield
|
|
4 v push
|
|
] with-lock
|
|
c count-down
|
|
] "Lock test 2" spawn drop
|
|
|
|
c await
|
|
v
|
|
] ;
|
|
|
|
[ V{ 1 3 2 4 } ] [ lock-test-0 ] unit-test
|
|
[ V{ 1 2 3 4 } ] [ lock-test-1 ] unit-test
|
|
|
|
[ 3 ] [
|
|
<reentrant-lock> dup [
|
|
[
|
|
3
|
|
] with-lock
|
|
] with-lock
|
|
] unit-test
|
|
|
|
[ ] [ <rw-lock> drop ] unit-test
|
|
|
|
[ ] [ <rw-lock> [ ] with-read-lock ] unit-test
|
|
|
|
[ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-read-lock ] unit-test
|
|
|
|
[ ] [ <rw-lock> [ ] with-write-lock ] unit-test
|
|
|
|
[ ] [ <rw-lock> dup [ [ ] with-write-lock ] with-write-lock ] unit-test
|
|
|
|
[ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-write-lock ] unit-test
|
|
|
|
:: rw-lock-test-1 ( -- v )
|
|
[let | l [ <rw-lock> ]
|
|
c [ 1 <count-down> ]
|
|
c' [ 1 <count-down> ]
|
|
c'' [ 4 <count-down> ]
|
|
v [ V{ } clone ] |
|
|
|
|
[
|
|
l [
|
|
1 v push
|
|
c count-down
|
|
yield
|
|
3 v push
|
|
] with-read-lock
|
|
c'' count-down
|
|
] "R/W lock test 1" spawn drop
|
|
|
|
[
|
|
c await
|
|
l [
|
|
4 v push
|
|
1 seconds sleep
|
|
5 v push
|
|
] with-write-lock
|
|
c'' count-down
|
|
] "R/W lock test 2" spawn drop
|
|
|
|
[
|
|
c await
|
|
l [
|
|
2 v push
|
|
c' count-down
|
|
] with-read-lock
|
|
c'' count-down
|
|
] "R/W lock test 4" spawn drop
|
|
|
|
[
|
|
c' await
|
|
l [
|
|
6 v push
|
|
] with-write-lock
|
|
c'' count-down
|
|
] "R/W lock test 5" spawn drop
|
|
|
|
c'' await
|
|
v
|
|
] ;
|
|
|
|
[ V{ 1 2 3 4 5 6 } ] [ rw-lock-test-1 ] unit-test
|
|
|
|
:: rw-lock-test-2 ( -- v )
|
|
[let | l [ <rw-lock> ]
|
|
c [ 1 <count-down> ]
|
|
c' [ 2 <count-down> ]
|
|
v [ V{ } clone ] |
|
|
|
|
[
|
|
l [
|
|
1 v push
|
|
c count-down
|
|
1 seconds sleep
|
|
2 v push
|
|
] with-write-lock
|
|
c' count-down
|
|
] "R/W lock test 1" spawn drop
|
|
|
|
[
|
|
c await
|
|
l [
|
|
3 v push
|
|
] with-read-lock
|
|
c' count-down
|
|
] "R/W lock test 2" spawn drop
|
|
|
|
c' await
|
|
v
|
|
] ;
|
|
|
|
[ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test
|
|
|
|
! Test lock timeouts
|
|
:: lock-timeout-test ( -- v )
|
|
[let | l [ <lock> ] |
|
|
[
|
|
l [ 1 seconds sleep ] with-lock
|
|
] "Lock holder" spawn drop
|
|
|
|
[
|
|
l 1/10 seconds [ ] with-lock-timeout
|
|
] "Lock timeout-er" spawn-linked drop
|
|
|
|
receive
|
|
] ;
|
|
|
|
[ lock-timeout-test ] [
|
|
thread>> name>> "Lock timeout-er" =
|
|
] must-fail-with
|
|
|
|
[
|
|
<rw-lock> dup [
|
|
1 seconds [ ] with-write-lock-timeout
|
|
] with-read-lock
|
|
] must-fail
|
|
|
|
[
|
|
<rw-lock> dup [
|
|
dup [
|
|
1 seconds [ ] with-write-lock-timeout
|
|
] with-read-lock
|
|
] with-write-lock
|
|
] must-fail
|
|
|
|
[ ] [
|
|
<rw-lock> dup [
|
|
dup [
|
|
1 seconds [ ] with-read-lock-timeout
|
|
] with-read-lock
|
|
] with-write-lock
|
|
] unit-test
|