basis/concurrency/locks/locks-tests.factor

   1 USING: tools.test concurrency.locks concurrency.count-downs
   2 concurrency.messaging concurrency.mailboxes kernel
   3 threads sequences calendar accessors ;
   4 IN: concurrency.locks.tests
   5
   6 :: lock-test-0 ( -- v )
   7     V{ } clone :> v
   8     2 <count-down> :> c
   9
  10     [
  11         yield
  12         1 v push
  13         yield
  14         2 v push
  15         c count-down
  16     ] "Lock test 1" spawn drop
  17
  18     [
  19         yield
  20         3 v push
  21         yield
  22         4 v push
  23         c count-down
  24     ] "Lock test 2" spawn drop
  25
  26     c await
  27     v ;
  28
  29 :: lock-test-1 ( -- v )
  30     V{ } clone :> v
  31     <lock> :> l
  32     2 <count-down> :> c
  33
  34     [
  35         l [
  36             yield
  37             1 v push
  38             yield
  39             2 v push
  40         ] with-lock
  41         c count-down
  42     ] "Lock test 1" spawn drop
  43
  44     [
  45         l [
  46             yield
  47             3 v push
  48             yield
  49             4 v push
  50         ] with-lock
  51         c count-down
  52     ] "Lock test 2" spawn drop
  53
  54     c await
  55     v ;
  56
  57 { V{ 1 3 2 4 } } [ lock-test-0 ] unit-test
  58 { V{ 1 2 3 4 } } [ lock-test-1 ] unit-test
  59
  60 { 3 } [
  61     <reentrant-lock> dup [
  62         [
  63             3
  64         ] with-lock
  65     ] with-lock
  66 ] unit-test
  67
  68 { } [ <rw-lock> drop ] unit-test
  69
  70 { } [ <rw-lock> [ ] with-read-lock ] unit-test
  71
  72 { } [ <rw-lock> dup [ [ ] with-read-lock ] with-read-lock ] unit-test
  73
  74 { } [ <rw-lock> [ ] with-write-lock ] unit-test
  75
  76 { } [ <rw-lock> dup [ [ ] with-write-lock ] with-write-lock ] unit-test
  77
  78 { } [ <rw-lock> dup [ [ ] with-read-lock ] with-write-lock ] unit-test
  79
  80 :: rw-lock-test-1 ( -- v )
  81     <rw-lock> :> l
  82     1 <count-down> :> c
  83     1 <count-down> :> c'
  84     4 <count-down> :> c''
  85     V{ } clone :> v
  86
  87     [
  88         l [
  89             1 v push
  90             c count-down
  91             yield
  92             3 v push
  93         ] with-read-lock
  94         c'' count-down
  95     ] "R/W lock test 1" spawn drop
  96
  97     [
  98         c await
  99         l [
 100             4 v push
 101             1 seconds sleep
 102             5 v push
 103         ] with-write-lock
 104         c'' count-down
 105     ] "R/W lock test 2" spawn drop
 106
 107     [
 108         c await
 109         l [
 110             2 v push
 111             c' count-down
 112         ] with-read-lock
 113         c'' count-down
 114     ] "R/W lock test 4" spawn drop
 115
 116     [
 117         c' await
 118         l [
 119             6 v push
 120         ] with-write-lock
 121         c'' count-down
 122     ] "R/W lock test 5" spawn drop
 123
 124     c'' await
 125     v ;
 126
 127 { V{ 1 2 3 4 5 6 } } [ rw-lock-test-1 ] unit-test
 128
 129 :: rw-lock-test-2 ( -- v )
 130     <rw-lock> :> l
 131     1 <count-down> :> c
 132     2 <count-down> :> c'
 133     V{ } clone :> v
 134
 135     [
 136         l [
 137             1 v push
 138             c count-down
 139             1 seconds sleep
 140             2 v push
 141         ] with-write-lock
 142         c' count-down
 143     ] "R/W lock test 1" spawn drop
 144
 145     [
 146         c await
 147         l [
 148             3 v push
 149         ] with-read-lock
 150         c' count-down
 151     ] "R/W lock test 2" spawn drop
 152
 153     c' await
 154     v ;
 155
 156 { V{ 1 2 3 } } [ rw-lock-test-2 ] unit-test
 157
 158 ! Test lock timeouts
 159 :: lock-timeout-test ( -- v )
 160     <lock> :> l
 161
 162     [
 163         l [ 1 seconds sleep ] with-lock
 164     ] "Lock holder" spawn drop
 165
 166     [
 167         l 1/10 seconds [ ] with-lock-timeout
 168     ] "Lock timeout-er" spawn-linked drop
 169
 170     receive ;
 171
 172 [ lock-timeout-test ] [
 173     thread>> name>> "Lock timeout-er" =
 174 ] must-fail-with
 175
 176 [
 177     <rw-lock> dup [
 178         1 seconds [ ] with-write-lock-timeout
 179     ] with-read-lock
 180 ] must-fail
 181
 182 [
 183     <rw-lock> dup [
 184         dup [
 185             1 seconds [ ] with-write-lock-timeout
 186         ] with-read-lock
 187     ] with-write-lock
 188 ] must-fail
 189
 190 { } [
 191     <rw-lock> dup [
 192         dup [
 193             1 seconds [ ] with-read-lock-timeout
 194         ] with-read-lock
 195     ] with-write-lock
 196 ] unit-test