File: gnatcoll-pools.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 (356 lines) | stat: -rw-r--r-- 11,793 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
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
------------------------------------------------------------------------------
--                             M O D E L I N G                              --
--                                                                          --
--                     Copyright (C) 2010-2017, AdaCore                     --
--                                                                          --
-- This library is free software;  you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software  Foundation;  either version 3,  or (at your  option) any later --
-- version. This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY;  without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.                            --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Unchecked_Deallocation;
with GNATCOLL.Refcount;           use GNATCOLL.Refcount;
with GNATCOLL.Traces;             use GNATCOLL.Traces;
with Interfaces;                  use Interfaces;

package body GNATCOLL.Pools is
   use Pointers;

   Me : constant Trace_Handle := Create ("Pools");

   type Pool_Array is array (Positive range <>) of Pool_Resource_Access;
   type Pool_Array_Access is access all Pool_Array;

   type Resource_Set_Data is record
      Elements  : Pool_Array_Access;
      Param     : aliased Factory_Param;
      Available : aliased Integer_32 := 0;
   end record;

   type Sets is array (Resource_Set range <>) of Resource_Set_Data;
   type Sets_Access is access all Sets;

   procedure Unchecked_Free is new Ada.Unchecked_Deallocation
     (Pool_Resource, Pool_Resource_Access);
   procedure Unchecked_Free is new Ada.Unchecked_Deallocation
     (Pool_Array, Pool_Array_Access);
   procedure Unchecked_Free is new Ada.Unchecked_Deallocation
     (Sets, Sets_Access);

   protected type Pool is
      entry Get (Resource_Set) (Element : out Resource'Class);
      --  Get one resource
      --  You must have called Set_Factory before.
      --  The resource must be released explicitly by calling Release, or
      --  there will be starvation

      procedure Release
        (In_Pool : in out Pool_Resource_Access; Set : Resource_Set);
      --  Release the resource, and make it available to others.
      --  In_Pool might have been freed on exit

      procedure Set_Factory
        (Descr        : Factory_Param;
         Max_Elements : Positive;
         Set          : Resource_Set);
      --  Describe how to connect to the database. This can be called only
      --  once ie before getting the first connection

      procedure Free;
      --  Detach all resources from the pool.
      --  If they are in use elsewhere they will not be freed immediately, only
      --  when they are no longer in use.

      function Get_Factory_Param
        (Set : Resource_Set) return access Factory_Param;

   private
      Elements  : Sets_Access;
   end Pool;

   protected body Pool is

      -----------------
      -- Set_Factory --
      -----------------

      procedure Set_Factory
        (Descr        : Factory_Param;
         Max_Elements : Positive;
         Set          : Resource_Set) is
      begin
         if Elements = null then
            Elements := new Sets (Resource_Set'Range);
         end if;

         if Elements (Set).Elements = null then
            Elements (Set) :=
              (Elements => new Pool_Array'(1 .. Max_Elements => null),
               Available => Integer_32 (Max_Elements),
               Param     => Descr);
         else
            raise Program_Error with
              "Set_Factory can be called only once per resource_set";
         end if;
      end Set_Factory;

      -----------------------
      -- Get_Factory_Param --
      -----------------------

      function Get_Factory_Param
        (Set : Resource_Set) return access Factory_Param is
      begin
         return Elements (Set).Param'Access;
      end Get_Factory_Param;

      ---------
      -- Get --
      ---------

      entry Get (for Set in Resource_Set) (Element : out Resource'Class)
        when Elements (Set).Available > 0
      is
         In_Pool : Resource_Data;
      begin
         Elements (Set).Available := Elements (Set).Available - 1;

         --  Get the first available resource. Since they are allocated
         --  sequentially, this ensures that we preferably reuse an existing
         --  connection rather than create a new one.

         for E in Elements (Set).Elements'Range loop
            if Elements (Set).Elements (E) = null then
               --  ??? Issue: the factory might take a long time (for
               --  instance establishing a database connection). During
               --  that time, all threads waiting on Get are blocked.
               --  We should mark the slot as no longer available, and
               --  initialize the resource once returned to the user.

               Trace (Me, "Get: creating resource, at index" & E'Img);

               --  We have to cheat with the refcounting temporarily: the
               --  above call, if initialized at refcount=1, would call
               --  adjust once, and then finalize, thus try to call Release,
               --  resulting in a deadlock. Instead, we start with an
               --  off-by-one refcount, and put things back straight afterward.

               Elements (Set).Elements (E) := new Pool_Resource'
                 (Element           => Factory (Elements (Set).Param),
                  Available         => False);

               In_Pool := Resource_Data'
                 (Set    => Set,
                  In_Set => Elements (Set).Elements (E));
               Element.Set (In_Pool);
               return;

            elsif Elements (Set).Elements (E).Available then
               if Active (Me) then
                  Trace (Me, "Get: pool " & Set'Img
                         & " returning resources at index" & E'Img);
               end if;
               Elements (Set).Elements (E).Available         := False;

               In_Pool := Resource_Data'
                 (Set    => Set,
                  In_Set => Elements (Set).Elements (E));
               Element.Set (In_Pool);
               return;
            end if;
         end loop;

         --  The entry guard said we had an available resource
         raise Program_Error with "A resource should have been available";
      end Get;

      -------------
      -- Release --
      -------------

      procedure Release
        (In_Pool : in out Pool_Resource_Access; Set : Resource_Set)
      is
      begin
         --  Nothing to do after the pool itself has been freed.
         --  Normal reference counting will take place

         if Elements /= null then
            Trace (Me, "Released one resource");
            In_Pool.Available := True;
            Elements (Set).Available := Elements (Set).Available + 1;
         else
            --  The pool has been destroyed and the resource is no longer used.
            --  Simply free it.

            Free (In_Pool.Element);
            Unchecked_Free (In_Pool);
         end if;
      end Release;

      ----------
      -- Free --
      ----------

      procedure Free is
         R : Pool_Resource_Access;
      begin
         Increase_Indent (Me, "Global_Pool.Free");

         if Elements /= null then
            for Set in Elements'Range loop
               if Elements (Set).Elements /= null then
                  for E in Elements (Set).Elements'Range loop
                     R := Elements (Set).Elements (E);

                     if R /= null
                       and then R.Available
                     then
                        Trace (Me, "Freeing a resource");
                        Free (R.Element);
                        Unchecked_Free (R);
                     elsif R /= null then
                        Trace
                          (Me, "One resource still in use, can't be freed");
                     end if;
                  end loop;

                  Free_Param (Elements (Set).Param);
                  Unchecked_Free (Elements (Set).Elements);
               end if;
            end loop;

            Unchecked_Free (Elements);
         end if;

         Decrease_Indent (Me, "Done Global_Pool.Free");
      end Free;
   end Pool;

   Global_Pool : Pool;
   --  a global pool
   --  This is task safe.

   -------------
   -- Element --
   -------------

   function Element (Self : Resource) return access Element_Type is
      Enc : access Resource_Data := Get (Self).Element;
   begin
      Assert (Me, Enc /= null,
              "A wrapper should not exist without an element");
      return Enc.In_Set.Element'Access;
   end Element;

   ---------
   -- Get --
   ---------

   procedure Get
     (Self : out Resource'Class; Set : Resource_Set := Default_Set) is
   begin
      Global_Pool.Get (Set) (Self);
   end Get;

   --------------
   -- Get_Weak --
   --------------

   function Get_Weak (Self : Resource'Class) return Weak_Resource is
   begin
      return Weak_Resource'(Ref => Self.Weak);
   end Get_Weak;

   ---------
   -- Get --
   ---------

   procedure Get (Self : Weak_Resource; Res : out Resource) is
   begin
      Res.Set (Self.Ref);
   end Get;

   ---------------
   -- Was_Freed --
   ---------------

   function Was_Freed (Self : Weak_Resource) return Boolean is
   begin
      return Pointers.Was_Freed (Self.Ref);
   end Was_Freed;

   ----------
   -- Free --
   ----------

   procedure Free is
   begin
      Global_Pool.Free;
   end Free;

   ----------
   -- Free --
   ----------

   procedure Free (Self : in out Resource_Data) is
   begin
      --  Call the user's callback before releasing into the pool, so that the
      --  resource doesn't get reused in the meantime.

      On_Release (Self.In_Set.Element);

      begin
         Global_Pool.Release (Self.In_Set, Self.Set);
      exception
         when E : Program_Error =>
            Trace (Me, "Global pool was already finalized");
            Trace (Me, E);
      end;
   end Free;

   -----------------
   -- Set_Factory --
   -----------------

   procedure Set_Factory
     (Param        : Factory_Param;
      Max_Elements : Positive;
      Set          : Resource_Set := Default_Set) is
   begin
      Global_Pool.Set_Factory (Param, Max_Elements, Set);
   end Set_Factory;

   -----------------------
   -- Get_Factory_Param --
   -----------------------

   function Get_Factory_Param
     (Set : Resource_Set := Default_Set) return access Factory_Param is
   begin
      return Global_Pool.Get_Factory_Param (Set);
   end Get_Factory_Param;

   ------------------
   -- Get_Refcount --
   ------------------

   function Get_Refcount (Self : Resource) return Natural is
   begin
      return Pointers.Get_Refcount (Self);
   end Get_Refcount;

end GNATCOLL.Pools;