File: gnatcoll-ravenscar-multiple_queue_cyclic_server.adb

package info (click to toggle)
libgnatcoll 18-4
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, sid
  • size: 5,068 kB
  • sloc: ada: 40,393; python: 354; ansic: 310; makefile: 245; sh: 31
file content (161 lines) | stat: -rw-r--r-- 5,744 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
------------------------------------------------------------------------------
--                                                                          --
--                	        G N A T C O L L                             --
--                                                                          --
--                      Copyright (C) 2008-2017, AdaCore                    --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, USA.                                              --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with GNATCOLL.Ravenscar.Utils;

package body GNATCOLL.Ravenscar.Multiple_Queue_Cyclic_Server is
   use GNATCOLL.Ravenscar.Utils;

   procedure Put_Request
     (Req      : Request;
      Kind : Request_Kind)
   is
   begin

      --  Simply delegates to Protocol.Put

      Protocol.Put (Req, Kind);

   end Put_Request;

   protected body Protocol is

      procedure Put (Req : Request; Kind : Request_Kind) is
         Ref : constant Request_Type_Ref :=
            Queues (Kind) (Insert_Index (Kind))'Access;
      begin

         --  put the Req in the appropriate queue

         Queues (Kind) (Insert_Index (Kind))   := Req;

         --  increase insert index

         Increase_Counter (Insert_Index (Kind), QS);
         if Pending < Pointer_Queue_Range_Max then
            Pending := Pending + 1;
         end if;

         --  save pointer to last Req on a queue

         Ptr_Queue (Pointer_Queue_Insert_Index) := (Kind, Ref);
         Increase_Counter
           (Pointer_Queue_Insert_Index,
            Pointer_Queue_Range_Max);

         --  If there has been an overflow, increase also the Extract index.
         --  This is because the insert index has surpassed the extract index,
         --  overwriting older request. It is thus necessary to increase the
         --  extract index to avoid to fetch a newly posted request instead
         --  of older ones.

         if Pointer_Queue_Overflow then
            Increase_Counter
              (Pointer_Queue_Extract_Index,
               Pointer_Queue_Range_Max);
         end if;

         --  Check if the Insert_Index is going to surpass the extract index

         if Pointer_Queue_Insert_Index = Pointer_Queue_Extract_Index then
            Pointer_Queue_Overflow := True;
         end if;

      end Put;

      procedure Get_Next_Request (Req : out Request) is
         Ref : Pointer_Queue_Item_Ref := null;
      begin

         --  If the insert and extract index have the same value, it is
         --  possible to avoid overflow if a request is fetched before a new
         --  one is posted: this case addresses exactly this.

         if Pointer_Queue_Insert_Index = Pointer_Queue_Extract_Index then
            Pointer_Queue_Overflow := False;
         end if;

         --  get the oldest Req

         Ref := Ptr_Queue (Pointer_Queue_Extract_Index)'Access;
         Increase_Counter
           (Pointer_Queue_Extract_Index,
            Pointer_Queue_Range_Max);

         Req     := Ref.Req.all;

         --  decrease number of pending requests

         Pending := Pending - 1;

      end Get_Next_Request;
      pragma Inline (Get_Next_Request);

      procedure Get (Req : out Request; Has_Pending : out Boolean) is
      begin

         --  check if there are pending requests

         Has_Pending := Pending > 0;
         if Pending > 0 then
            Get_Next_Request (Req);
         end if;

      end Get;

   end Protocol;

   task body Cyclic_Task is
      Req     : Request;
      Next_Time   : Ada.Real_Time.Time := System_Start_Time;
      Has_Pending : Boolean            := False;
      use Ada.Real_Time;
   begin

      Next_Time := Next_Time + Milliseconds (Phase);

      loop

         delay until Next_Time;

         Protocol.Get (Req, Has_Pending);

         if Has_Pending then
            Dispatch (Req);
         else
            Cyclic_Operation;
         end if;

         Next_Time := Next_Time + Milliseconds (Period);

      end loop;

   end Cyclic_Task;

end GNATCOLL.Ravenscar.Multiple_Queue_Cyclic_Server;