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