basis/concurrency/locks/locks-tests.factor

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