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-2019, 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
36with System.Task_Primitives.Operations;
37with System.Tasking.Initialization;
38with System.Parameters;
39
40package 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
625end System.Tasking.Queuing;
626