basis/concurrency/locks/locks-tests.factor

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