1{%skiptarget=$nothread } 2{$ifdef fpc} 3{$mode objfpc} 4{$h+} 5{$endif} 6 7uses 8{$ifdef unix} 9 cthreads, 10{$endif} 11 SysUtils, Classes; 12 13var 14 lock: TMultiReadExclusiveWriteSynchronizer; 15 event1, event2: prtlevent; 16 gcount: longint; 17 gotdeadlockexception, 18 waiting: boolean; 19 20type 21 terrorcheck = class(tthread) 22 procedure execute; override; 23 end; 24 25 tcounter = class(tthread) 26 private 27 flock: TMultiReadExclusiveWriteSynchronizer; 28 flocalcount: longint; 29 public 30 constructor create; 31 property localcount: longint read flocalcount; 32 end; 33 34 treadcounter = class(tcounter) 35 procedure execute; override; 36 end; 37 38 twritecounter = class(tcounter) 39 procedure execute; override; 40 end; 41 42 treadwritecounter = class(tcounter) 43 private 44 ftrywriteupgrade: boolean; 45 public 46 constructor create(trywriteupgrade: boolean); 47 procedure execute; override; 48 end; 49 50 tdeadlock1 = class(tthread) 51 procedure execute; override; 52 end; 53 54 tdeadlock2 = class(tthread) 55 procedure execute; override; 56 end; 57 58 tdoublereadonewrite1 = class(tthread) 59 procedure execute; override; 60 end; 61 62 tdoublereadonewrite2 = class(tthread) 63 procedure execute; override; 64 end; 65 66 twrongthreadendacquire = class(tthread) 67 ftestwrongreadrelease: boolean; 68 constructor create(testwrongreadrelease: boolean); 69 procedure execute; override; 70 end; 71 72 twrongthreadendrelease = class(tthread) 73 ftestwrongreadrelease: boolean; 74 constructor create(testwrongreadrelease: boolean); 75 procedure execute; override; 76 end; 77 78 tdoublewrite = class(tthread) 79 fsecondwritethread: boolean; 80 constructor create(secondwritethread: boolean); 81 procedure execute; override; 82 end; 83 84 85constructor tcounter.create; 86 begin 87 { create suspended } 88 inherited create(true); 89 freeonterminate:=false; 90 flock:=lock; 91 flocalcount:=0; 92 end; 93 94procedure treadcounter.execute; 95 var 96 i: longint; 97 l: longint; 98 r: longint; 99 begin 100 for i:=1 to 100000 do 101 begin 102 lock.beginread; 103 inc(flocalcount); 104 l:=gcount; 105 { guarantee at least one sleep } 106 if i=50000 then 107 sleep(20+random(30)) 108 else if (random(10000)=0) then 109 sleep(20); 110 { this must cause data races/loss at some point } 111 gcount:=l+1; 112 lock.endread; 113 r:=random(30000); 114 if (r=0) then 115 sleep(30); 116 end; 117 end; 118 119 120procedure twritecounter.execute; 121 var 122 i: longint; 123 l: longint; 124 r: longint; 125 begin 126 for i:=1 to 500 do 127 begin 128 lock.beginwrite; 129 inc(flocalcount); 130 l:=gcount; 131 { guarantee at least one sleep } 132 if i=250 then 133 sleep(20+random(30)) 134 else if (random(100)=0) then 135 sleep(20); 136 { we must be exclusive } 137 if gcount<>l then 138 begin 139 writeln('error 1'); 140 halt(1); 141 end; 142 gcount:=l+1; 143 lock.endwrite; 144 r:=random(30); 145 if (r>28) then 146 sleep(r); 147 end; 148 end; 149 150 151constructor treadwritecounter.create(trywriteupgrade: boolean); 152 begin 153 ftrywriteupgrade:=trywriteupgrade; 154 inherited create; 155 end; 156 157 158procedure treadwritecounter.execute; 159 var 160 i: longint; 161 l: longint; 162 r: longint; 163 begin 164 for i:=1 to 100000 do 165 begin 166 lock.beginread; 167 if ftrywriteupgrade and 168 ((i=50000) or 169 (random(10000)=0)) then 170 begin 171 inc(flocalcount); 172 lock.beginwrite; 173 l:=gcount; 174 { guarantee at least one sleep } 175 if i=50000 then 176 sleep(20+random(30)) 177 else if (random(5)=0) then 178 sleep(20); 179 lock.beginwrite; 180 gcount:=l+1; 181 lock.endwrite; 182 lock.endwrite; 183 end; 184 lock.endread; 185 r:=random(30000); 186 if (r=0) then 187 sleep(30); 188 end; 189 end; 190 191 192procedure tdeadlock1.execute; 193 var 194 localgotdeadlockexception: boolean; 195 begin 196 localgotdeadlockexception:=false; 197 lock.beginread; 198 RTLEventSetEvent(event2); 199 RTLEventWaitFor(event1); 200 try 201 lock.beginwrite; 202 except 203 localgotdeadlockexception:=true; 204 gotdeadlockexception:=true; 205 end; 206 if not localgotdeadlockexception then 207 lock.endwrite; 208 lock.endread; 209 end; 210 211 212procedure tdeadlock2.execute; 213 var 214 localgotdeadlockexception: boolean; 215 begin 216 localgotdeadlockexception:=false; 217 lock.beginread; 218 RTLEventSetEvent(event1); 219 RTLEventWaitFor(event2); 220 try 221 lock.beginwrite; 222 except 223 localgotdeadlockexception:=true; 224 gotdeadlockexception:=true; 225 end; 226 if not localgotdeadlockexception then 227 lock.endwrite; 228 lock.endread; 229 end; 230 231 232procedure tdoublereadonewrite1.execute; 233 begin 234 // 1) 235 lock.beginread; 236 // 2) 237 RTLEventSetEvent(event2); 238 // 5) 239 RTLEventWaitFor(event1); 240 { ensure tdoublereadonewrite2 has time to get stuck in beginwrite } 241 sleep(500); 242 // 6) 243 lock.beginread; 244 // 7) 245 lock.endread; 246 // 8) 247 lock.endread; 248 end; 249 250 251procedure tdoublereadonewrite2.execute; 252 begin 253 // 3) 254 RTLEventWaitFor(event2); 255 // 4) 256 RTLEventSetEvent(event1); 257 // 4a -- block until after 8) 258 lock.beginwrite; 259 // 9) 260 lock.endwrite; 261 end; 262 263 264constructor twrongthreadendacquire.create(testwrongreadrelease: boolean); 265 begin 266 ftestwrongreadrelease:=testwrongreadrelease; 267 inherited create(false); 268 end; 269 270 271procedure twrongthreadendacquire.execute; 272 begin 273 if ftestwrongreadrelease then 274 lock.beginread 275 else 276 lock.beginwrite; 277 RTLEventSetEvent(event1); 278 RTLEventWaitFor(event2); 279 try 280 if ftestwrongreadrelease then 281 lock.endread 282 else 283 lock.endwrite; 284 except 285 halt(30); 286 end; 287 end; 288 289 290constructor twrongthreadendrelease.create(testwrongreadrelease: boolean); 291 begin 292 ftestwrongreadrelease:=testwrongreadrelease; 293 inherited create(false); 294 end; 295 296 297procedure twrongthreadendrelease.execute; 298 var 299 caught: boolean; 300 begin 301 RTLEventWaitFor(event1); 302 caught:=false; 303 try 304 if ftestwrongreadrelease then 305 lock.endread 306 else 307 lock.endwrite; 308 except 309 caught:=true; 310 end; 311 RTLEventSetEvent(event2); 312 if not caught then 313 halt(40); 314 end; 315 316 317constructor tdoublewrite.create(secondwritethread: boolean); 318 begin 319 fsecondwritethread:=secondwritethread; 320 inherited create(false); 321 end; 322 323 324procedure tdoublewrite.execute; 325 begin 326 if fsecondwritethread then 327 begin 328 RTLEventWaitFor(event1); 329 if lock.beginwrite then 330 halt(50); 331 end 332 else 333 begin 334 if not lock.beginwrite then 335 halt(51); 336 RTLEventSetEvent(event1); 337 // give the other thread the time to get to its beginwrite call 338 Sleep(500); 339 end; 340 lock.endwrite; 341 end; 342 343 344procedure terrorcheck.execute; 345begin 346 { make sure we don't exit before this thread has initialised, since } 347 { it can allocate memory in its initialisation, which would cause } 348 { problems for heaptrc as it goes over the memory map in its exit code } 349 waiting:=true; 350 { avoid deadlocks/bugs from causing this test to never quit } 351 sleep(1000*60); 352 writeln('error 4'); 353 halt(4); 354end; 355 356 357var 358 r1,r2,r3,r4,r5,r6: treadcounter; 359 w1,w2,w3,w4: twritecounter; 360 rw1,rw2,rw3: treadwritecounter; 361 d1: tdeadlock1; 362 d2: tdeadlock2; 363 dr1: tdoublereadonewrite1; 364 dr2: tdoublereadonewrite2; 365 wr1: twrongthreadendacquire; 366 wr2: twrongthreadendrelease; 367 dw1, dw2: tdoublewrite; 368 caught: boolean; 369begin 370 waiting:=false; 371 terrorcheck.create(false); 372 randomize; 373 lock:=TMultiReadExclusiveWriteSynchronizer.create; 374 event1:=RTLEventCreate; 375 event2:=RTLEventCreate; 376 377 { verify that the lock is recursive } 378 if not lock.beginwrite then 379 halt(10); 380 if not lock.beginwrite then 381 halt(11); 382 lock.endwrite; 383 lock.endwrite; 384 385 { verify that we can upgrade a read lock to a write lock } 386 lock.beginread; 387 if not lock.beginwrite then 388 halt(12); 389 lock.endwrite; 390 lock.endread; 391 392 { verify that owning a write lock does not prevent getting a read lock } 393 if not lock.beginwrite then 394 halt(13); 395 lock.beginread; 396 lock.endread; 397 lock.endwrite; 398 399 { verify that calling endread without beginread throws an exception } 400 caught:=false; 401 try 402 lock.endread; 403 except 404 caught:=true; 405 end; 406 if not caught then 407 halt(14); 408 409 { verify that calling endwrite without beginwrite throws an exception } 410 caught:=false; 411 try 412 lock.endwrite; 413 except 414 caught:=true; 415 end; 416 if not caught then 417 halt(15); 418 419 420 { first try some writers } 421 w1:=twritecounter.create; 422 w2:=twritecounter.create; 423 w3:=twritecounter.create; 424 w4:=twritecounter.create; 425 w1.resume; 426 w2.resume; 427 w3.resume; 428 w4.resume; 429 w1.waitfor; 430 w2.waitfor; 431 w3.waitfor; 432 w4.waitfor; 433 434 { must not have caused any data races } 435 if (gcount<>w1.localcount+w2.localcount+w3.localcount+w4.localcount) then 436 begin 437 writeln('error 2'); 438 halt(2); 439 end; 440 441 w1.free; 442 w2.free; 443 w3.free; 444 w4.free; 445 446 { mixed readers and writers with proper synchronisation } 447 gcount:=0; 448 rw1:=treadwritecounter.create(true); 449 rw2:=treadwritecounter.create(false); 450 rw3:=treadwritecounter.create(false); 451 452 rw1.resume; 453 rw2.resume; 454 rw3.resume; 455 456 rw1.waitfor; 457 rw2.waitfor; 458 rw3.waitfor; 459 460 { must not have caused any data races } 461 if (gcount<>rw1.localcount+rw2.localcount+rw3.localcount) then 462 begin 463 writeln('error 5'); 464 halt(5); 465 end; 466 467 RTLEventResetEvent(event1); 468 RTLEventResetEvent(event2); 469 470 { check deadlock detection } 471 d1:=tdeadlock1.create(false); 472 d2:=tdeadlock2.create(false); 473 474 d1.waitfor; 475 d2.waitfor; 476 if not gotdeadlockexception then 477 halt(6); 478 479 d1.free; 480 d2.free; 481 482 483 { check that a waiting writer does not block a reader trying to get 484 a recursive read lock it already holds } 485 dr1:=tdoublereadonewrite1.create(false); 486 dr2:=tdoublereadonewrite2.create(false); 487 488 dr1.waitfor; 489 dr2.waitfor; 490 491 dr1.free; 492 dr2.free; 493 494 { check that releasing a lock in another thread compared to where it 495 was acquired causes an exception } 496 wr1:=twrongthreadendacquire.create(true); 497 wr2:=twrongthreadendrelease.create(true); 498 wr1.waitfor; 499 wr2.waitfor; 500 wr1.free; 501 wr2.free; 502 503 wr1:=twrongthreadendacquire.create(false); 504 wr2:=twrongthreadendrelease.create(false); 505 wr1.waitfor; 506 wr2.waitfor; 507 wr1.free; 508 wr2.free; 509 510 dw1:=tdoublewrite.create(false); 511 dw2:=tdoublewrite.create(true); 512 dw1.waitfor; 513 dw2.waitfor; 514 dw1.free; 515 dw2.free; 516 517 RTLEventDestroy(event1); 518 RTLEventDestroy(event2); 519 520 lock.free; 521 522 while not waiting do 523 sleep(20); 524end. 525