GCC v8.2
[gcc.git] / gcc / ada / libgnarl / s-tasque.adb
1 ------------------------------------------------------------------------------
2 --                                                                          --
3 --                  GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                --
4 --                                                                          --
5 --                 S Y S T E M . T A S K I N G . Q U E U I N G              --
6 --                                                                          --
7 --                                  B o d y                                 --
8 --                                                                          --
9 --         Copyright (C) 1992-2018, Free Software Foundation, Inc.          --
10 --                                                                          --
11 -- GNARL is free software; you can  redistribute it  and/or modify it under --
12 -- terms of the  GNU General Public License as published  by the Free Soft- --
13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
17 --                                                                          --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception,   --
20 -- version 3.1, as published by the Free Software Foundation.               --
21 --                                                                          --
22 -- You should have received a copy of the GNU General Public License and    --
23 -- a copy of the GCC Runtime Library Exception along with this program;     --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25 -- <http://www.gnu.org/licenses/>.                                          --
26 --                                                                          --
27 -- GNARL was developed by the GNARL team at Florida State University.       --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc.     --
29 --                                                                          --
30 ------------------------------------------------------------------------------
31
32 --  This version of the body implements queueing policy according to the policy
33 --  specified by the pragma Queuing_Policy. When no such pragma is specified
34 --  FIFO policy is used as default.
35
36 with System.Task_Primitives.Operations;
37 with System.Tasking.Initialization;
38 with System.Parameters;
39
40 package body System.Tasking.Queuing is
41
42    use Parameters;
43    use Task_Primitives.Operations;
44    use Protected_Objects;
45    use Protected_Objects.Entries;
46
47    --  Entry Queues implemented as doubly linked list
48
49    Queuing_Policy : Character;
50    pragma Import (C, Queuing_Policy, "__gl_queuing_policy");
51
52    Priority_Queuing : constant Boolean := Queuing_Policy = 'P';
53
54    procedure Send_Program_Error
55      (Self_ID    : Task_Id;
56       Entry_Call : Entry_Call_Link);
57    --  Raise Program_Error in the caller of the specified entry call
58
59    function Check_Queue (E : Entry_Queue) return Boolean;
60    --  Check the validity of E.
61    --  Return True if E is valid, raise Assert_Failure if assertions are
62    --  enabled and False otherwise.
63
64    -----------------------------
65    -- Broadcast_Program_Error --
66    -----------------------------
67
68    procedure Broadcast_Program_Error
69      (Self_ID      : Task_Id;
70       Object       : Protection_Entries_Access;
71       Pending_Call : Entry_Call_Link;
72       RTS_Locked   : Boolean := False)
73    is
74       Entry_Call : Entry_Call_Link;
75    begin
76       if Single_Lock and then not RTS_Locked then
77          Lock_RTS;
78       end if;
79
80       if Pending_Call /= null then
81          Send_Program_Error (Self_ID, Pending_Call);
82       end if;
83
84       for E in Object.Entry_Queues'Range loop
85          Dequeue_Head (Object.Entry_Queues (E), Entry_Call);
86
87          while Entry_Call /= null loop
88             pragma Assert (Entry_Call.Mode /= Conditional_Call);
89
90             Send_Program_Error (Self_ID, Entry_Call);
91             Dequeue_Head (Object.Entry_Queues (E), Entry_Call);
92          end loop;
93       end loop;
94
95       if Single_Lock and then not RTS_Locked then
96          Unlock_RTS;
97       end if;
98    end Broadcast_Program_Error;
99
100    -----------------
101    -- Check_Queue --
102    -----------------
103
104    function Check_Queue (E : Entry_Queue) return Boolean is
105       Valid   : Boolean := True;
106       C, Prev : Entry_Call_Link;
107
108    begin
109       if E.Head = null then
110          if E.Tail /= null then
111             Valid := False;
112             pragma Assert (Valid);
113          end if;
114       else
115          if E.Tail = null
116            or else E.Tail.Next /= E.Head
117          then
118             Valid := False;
119             pragma Assert (Valid);
120
121          else
122             C := E.Head;
123
124             loop
125                Prev := C;
126                C := C.Next;
127
128                if C = null then
129                   Valid := False;
130                   pragma Assert (Valid);
131                   exit;
132                end if;
133
134                if Prev /= C.Prev then
135                   Valid := False;
136                   pragma Assert (Valid);
137                   exit;
138                end if;
139
140                exit when C = E.Head;
141             end loop;
142
143             if Prev /= E.Tail then
144                Valid := False;
145                pragma Assert (Valid);
146             end if;
147          end if;
148       end if;
149
150       return Valid;
151    end Check_Queue;
152
153    -------------------
154    -- Count_Waiting --
155    -------------------
156
157    --  Return number of calls on the waiting queue of E
158
159    function Count_Waiting (E : Entry_Queue) return Natural is
160       Count   : Natural;
161       Temp    : Entry_Call_Link;
162
163    begin
164       pragma Assert (Check_Queue (E));
165
166       Count := 0;
167
168       if E.Head /= null then
169          Temp := E.Head;
170
171          loop
172             Count := Count + 1;
173             exit when E.Tail = Temp;
174             Temp := Temp.Next;
175          end loop;
176       end if;
177
178       return Count;
179    end Count_Waiting;
180
181    -------------
182    -- Dequeue --
183    -------------
184
185    --  Dequeue call from entry_queue E
186
187    procedure Dequeue (E : in out Entry_Queue; Call : Entry_Call_Link) is
188    begin
189       pragma Assert (Check_Queue (E));
190       pragma Assert (Call /= null);
191
192       --  If empty queue, simply return
193
194       if E.Head = null then
195          return;
196       end if;
197
198       pragma Assert (Call.Prev /= null);
199       pragma Assert (Call.Next /= null);
200
201       Call.Prev.Next := Call.Next;
202       Call.Next.Prev := Call.Prev;
203
204       if E.Head = Call then
205
206          --  Case of one element
207
208          if E.Tail = Call then
209             E.Head := null;
210             E.Tail := null;
211
212          --  More than one element
213
214          else
215             E.Head := Call.Next;
216          end if;
217
218       elsif E.Tail = Call then
219          E.Tail := Call.Prev;
220       end if;
221
222       --  Successfully dequeued
223
224       Call.Prev := null;
225       Call.Next := null;
226       pragma Assert (Check_Queue (E));
227    end Dequeue;
228
229    ------------------
230    -- Dequeue_Call --
231    ------------------
232
233    procedure Dequeue_Call (Entry_Call : Entry_Call_Link) is
234       Called_PO : Protection_Entries_Access;
235
236    begin
237       pragma Assert (Entry_Call /= null);
238
239       if Entry_Call.Called_Task /= null then
240          Dequeue
241            (Entry_Call.Called_Task.Entry_Queues
242              (Task_Entry_Index (Entry_Call.E)),
243            Entry_Call);
244
245       else
246          Called_PO := To_Protection (Entry_Call.Called_PO);
247          Dequeue (Called_PO.Entry_Queues
248              (Protected_Entry_Index (Entry_Call.E)),
249            Entry_Call);
250       end if;
251    end Dequeue_Call;
252
253    ------------------
254    -- Dequeue_Head --
255    ------------------
256
257    --  Remove and return the head of entry_queue E
258
259    procedure Dequeue_Head
260      (E    : in out Entry_Queue;
261       Call : out Entry_Call_Link)
262    is
263       Temp : Entry_Call_Link;
264
265    begin
266       pragma Assert (Check_Queue (E));
267       --  If empty queue, return null pointer
268
269       if E.Head = null then
270          Call := null;
271          return;
272       end if;
273
274       Temp := E.Head;
275
276       --  Case of one element
277
278       if E.Head = E.Tail then
279          E.Head := null;
280          E.Tail := null;
281
282       --  More than one element
283
284       else
285          pragma Assert (Temp /= null);
286          pragma Assert (Temp.Next /= null);
287          pragma Assert (Temp.Prev /= null);
288
289          E.Head := Temp.Next;
290          Temp.Prev.Next := Temp.Next;
291          Temp.Next.Prev := Temp.Prev;
292       end if;
293
294       --  Successfully dequeued
295
296       Temp.Prev := null;
297       Temp.Next := null;
298       Call := Temp;
299       pragma Assert (Check_Queue (E));
300    end Dequeue_Head;
301
302    -------------
303    -- Enqueue --
304    -------------
305
306    --  Enqueue call at the end of entry_queue E, for FIFO queuing policy.
307    --  Enqueue call priority ordered, FIFO at same priority level, for
308    --  Priority queuing policy.
309
310    procedure Enqueue (E : in out Entry_Queue; Call : Entry_Call_Link) is
311       Temp : Entry_Call_Link := E.Head;
312
313    begin
314       pragma Assert (Check_Queue (E));
315       pragma Assert (Call /= null);
316
317       --  Priority Queuing
318
319       if Priority_Queuing then
320          if Temp = null then
321             Call.Prev := Call;
322             Call.Next := Call;
323             E.Head := Call;
324             E.Tail := Call;
325
326          else
327             loop
328                --  Find the entry that the new guy should precede
329
330                exit when Call.Prio > Temp.Prio;
331                Temp := Temp.Next;
332
333                if Temp = E.Head then
334                   Temp := null;
335                   exit;
336                end if;
337             end loop;
338
339             if Temp = null then
340                --  Insert at tail
341
342                Call.Prev := E.Tail;
343                Call.Next := E.Head;
344                E.Tail := Call;
345
346             else
347                Call.Prev := Temp.Prev;
348                Call.Next := Temp;
349
350                --  Insert at head
351
352                if Temp = E.Head then
353                   E.Head := Call;
354                end if;
355             end if;
356
357             pragma Assert (Call.Prev /= null);
358             pragma Assert (Call.Next /= null);
359
360             Call.Prev.Next := Call;
361             Call.Next.Prev := Call;
362          end if;
363
364          pragma Assert (Check_Queue (E));
365          return;
366       end if;
367
368       --  FIFO Queuing
369
370       if E.Head = null then
371          E.Head := Call;
372       else
373          E.Tail.Next := Call;
374          Call.Prev   := E.Tail;
375       end if;
376
377       E.Head.Prev := Call;
378       E.Tail      := Call;
379       Call.Next   := E.Head;
380       pragma Assert (Check_Queue (E));
381    end Enqueue;
382
383    ------------------
384    -- Enqueue_Call --
385    ------------------
386
387    procedure Enqueue_Call (Entry_Call : Entry_Call_Link) is
388       Called_PO : Protection_Entries_Access;
389
390    begin
391       pragma Assert (Entry_Call /= null);
392
393       if Entry_Call.Called_Task /= null then
394          Enqueue
395            (Entry_Call.Called_Task.Entry_Queues
396               (Task_Entry_Index (Entry_Call.E)),
397            Entry_Call);
398
399       else
400          Called_PO := To_Protection (Entry_Call.Called_PO);
401          Enqueue (Called_PO.Entry_Queues
402              (Protected_Entry_Index (Entry_Call.E)),
403            Entry_Call);
404       end if;
405    end Enqueue_Call;
406
407    ----------
408    -- Head --
409    ----------
410
411    --  Return the head of entry_queue E
412
413    function Head (E : Entry_Queue) return Entry_Call_Link is
414    begin
415       pragma Assert (Check_Queue (E));
416       return E.Head;
417    end Head;
418
419    -------------
420    -- Onqueue --
421    -------------
422
423    --  Return True if Call is on any entry_queue at all
424
425    function Onqueue (Call : Entry_Call_Link) return Boolean is
426    begin
427       pragma Assert (Call /= null);
428
429       --  Utilize the fact that every queue is circular, so if Call
430       --  is on any queue at all, Call.Next must NOT be null.
431
432       return Call.Next /= null;
433    end Onqueue;
434
435    --------------------------------
436    -- Requeue_Call_With_New_Prio --
437    --------------------------------
438
439    procedure Requeue_Call_With_New_Prio
440      (Entry_Call : Entry_Call_Link; Prio : System.Any_Priority) is
441    begin
442       pragma Assert (Entry_Call /= null);
443
444       --  Perform a queue reordering only when the policy being used is the
445       --  Priority Queuing.
446
447       if Priority_Queuing then
448          if Onqueue (Entry_Call) then
449             Dequeue_Call (Entry_Call);
450             Entry_Call.Prio := Prio;
451             Enqueue_Call (Entry_Call);
452          end if;
453       end if;
454    end Requeue_Call_With_New_Prio;
455
456    ---------------------------------
457    -- Select_Protected_Entry_Call --
458    ---------------------------------
459
460    --  Select an entry of a protected object. Selection depends on the
461    --  queuing policy being used.
462
463    procedure Select_Protected_Entry_Call
464      (Self_ID : Task_Id;
465       Object  : Protection_Entries_Access;
466       Call    : out Entry_Call_Link)
467    is
468       Entry_Call  : Entry_Call_Link;
469       Temp_Call   : Entry_Call_Link;
470       Entry_Index : Protected_Entry_Index := Null_Entry; -- stop warning
471
472    begin
473       Entry_Call := null;
474
475       begin
476          --  Priority queuing case
477
478          if Priority_Queuing then
479             for J in Object.Entry_Queues'Range loop
480                Temp_Call := Head (Object.Entry_Queues (J));
481
482                if Temp_Call /= null
483                  and then
484                    Object.Entry_Bodies
485                      (Object.Find_Body_Index
486                        (Object.Compiler_Info, J)).
487                           Barrier (Object.Compiler_Info, J)
488                then
489                   if Entry_Call = null
490                     or else Entry_Call.Prio < Temp_Call.Prio
491                   then
492                      Entry_Call := Temp_Call;
493                      Entry_Index := J;
494                   end if;
495                end if;
496             end loop;
497
498          --  FIFO queueing case
499
500          else
501             for J in Object.Entry_Queues'Range loop
502                Temp_Call := Head (Object.Entry_Queues (J));
503
504                if Temp_Call /= null
505                  and then
506                    Object.Entry_Bodies
507                      (Object.Find_Body_Index
508                        (Object.Compiler_Info, J)).
509                           Barrier (Object.Compiler_Info, J)
510                then
511                   Entry_Call := Temp_Call;
512                   Entry_Index := J;
513                   exit;
514                end if;
515             end loop;
516          end if;
517
518       exception
519          when others =>
520             Broadcast_Program_Error (Self_ID, Object, null);
521       end;
522
523       --  If a call was selected, dequeue it and return it for service
524
525       if Entry_Call /= null then
526          Temp_Call := Entry_Call;
527          Dequeue_Head (Object.Entry_Queues (Entry_Index), Entry_Call);
528          pragma Assert (Temp_Call = Entry_Call);
529       end if;
530
531       Call := Entry_Call;
532    end Select_Protected_Entry_Call;
533
534    ----------------------------
535    -- Select_Task_Entry_Call --
536    ----------------------------
537
538    --  Select an entry for rendezvous. Selection depends on the queuing policy
539    --  being used.
540
541    procedure Select_Task_Entry_Call
542      (Acceptor         : Task_Id;
543       Open_Accepts     : Accept_List_Access;
544       Call             : out Entry_Call_Link;
545       Selection        : out Select_Index;
546       Open_Alternative : out Boolean)
547    is
548       Entry_Call  : Entry_Call_Link;
549       Temp_Call   : Entry_Call_Link;
550       Entry_Index : Task_Entry_Index := Task_Entry_Index'First;
551       Temp_Entry  : Task_Entry_Index;
552
553    begin
554       Open_Alternative := False;
555       Entry_Call       := null;
556       Selection        := No_Rendezvous;
557
558       if Priority_Queuing then
559          --  Priority queueing case
560
561          for J in Open_Accepts'Range loop
562             Temp_Entry := Open_Accepts (J).S;
563
564             if Temp_Entry /= Null_Task_Entry then
565                Open_Alternative := True;
566                Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
567
568                if Temp_Call /= null
569                  and then (Entry_Call = null
570                    or else Entry_Call.Prio < Temp_Call.Prio)
571                then
572                   Entry_Call  := Head (Acceptor.Entry_Queues (Temp_Entry));
573                   Entry_Index := Temp_Entry;
574                   Selection := J;
575                end if;
576             end if;
577          end loop;
578
579       else
580          --  FIFO Queuing case
581
582          for J in Open_Accepts'Range loop
583             Temp_Entry := Open_Accepts (J).S;
584
585             if Temp_Entry /= Null_Task_Entry then
586                Open_Alternative := True;
587                Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
588
589                if Temp_Call /= null then
590                   Entry_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
591                   Entry_Index := Temp_Entry;
592                   Selection := J;
593                   exit;
594                end if;
595             end if;
596          end loop;
597       end if;
598
599       if Entry_Call /= null then
600          Dequeue_Head (Acceptor.Entry_Queues (Entry_Index), Entry_Call);
601
602          --  Guard is open
603       end if;
604
605       Call := Entry_Call;
606    end Select_Task_Entry_Call;
607
608    ------------------------
609    -- Send_Program_Error --
610    ------------------------
611
612    procedure Send_Program_Error
613      (Self_ID    : Task_Id;
614       Entry_Call : Entry_Call_Link)
615    is
616       Caller : Task_Id;
617    begin
618       Caller := Entry_Call.Self;
619       Entry_Call.Exception_To_Raise := Program_Error'Identity;
620       Write_Lock (Caller);
621       Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
622       Unlock (Caller);
623    end Send_Program_Error;
624
625 end System.Tasking.Queuing;