Natools

Check-in [f530098004]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:references-pools: new package that provides a task-safe pool of references
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: f5300980040c16d71c07b622085cb380de891e53
User & Date: nat on 2014-08-26 20:50:16
Other Links: manifest | tags
Context
2014-08-27
19:43
reference_tests-pools: new test suite for reference pools check-in: 2fa0bb02a5 user: nat tags: trunk
2014-08-26
20:50
references-pools: new package that provides a task-safe pool of references check-in: f530098004 user: nat tags: trunk
2014-08-25
19:57
reference_tests: also test the new Is_Last function check-in: 111a93ca40 user: nat tags: trunk
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Added src/natools-references-pools.adb version [0b765e01db]. 


















































































































































































































































































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

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

------------------------------------------------------------------------------
-- Copyright (c) 2014, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

package body Natools.References.Pools is

   ------------------------
   -- Helper Subprograms --
   ------------------------

   overriding procedure Finalize (Object : in out Pool_Backend) is
   begin
      Unchecked_Free (Object.Refs);
   end Finalize;


   procedure Find
     (Container : in Pool_Backend;
      First_Available : out Extended_Index;
      First_Empty : out Extended_Index) is
   begin
      First_Available := 0;
      First_Empty := 0;

      if Container.Refs = null then
         return;
      end if;

      for I in Container.Refs'Range loop
         if Container.Refs (I).Is_Empty then
            if First_Empty = 0 then
               First_Empty := I;
               exit when First_Available /= 0;
            end if;
         elsif Container.Refs (I).Is_Last then
            if First_Available = 0 then
               First_Available := I;
               exit when First_Empty /= 0;
            end if;
         end if;
      end loop;
   end Find;


   not overriding procedure Preallocate
     (Container : in out Pool_Backend;
      New_Item_Count : in Pool_Size;
      Constructor : access function return Held_Data := null) is
   begin
      if New_Item_Count = 0 then
         return;
      end if;

      if Container.Refs = null then
         Container.Refs := new Reference_Array (1 .. New_Item_Count);

         if Constructor /= null then
            for I in Container.Refs'Range loop
               Container.Refs (I) := Create (Constructor);
            end loop;
         end if;

      else
         declare
            New_Data : Reference_Array_Access
              := new Reference_Array
                 (1 .. Container.Refs'Length + New_Item_Count);
         begin
            New_Data (1 .. Container.Refs'Length) := Container.Refs.all;

            if Constructor /= null then
               for I in Container.Refs'Length + 1 .. New_Data'Last loop
                  New_Data (I) := Create (Constructor);
               end loop;
            end if;

            Unchecked_Free (Container.Refs);
            Container.Refs := New_Data;
         exception
            when others =>
               Unchecked_Free (New_Data);
               raise;
         end;
      end if;
   end Preallocate;



   ----------------------------------
   -- Public Protected Subprograms --
   ----------------------------------

   protected body Pool is

      procedure Get (Ref : out Reference) is
         First_Available, First_Empty : Extended_Index;
      begin
         Backend.Find (First_Available, First_Empty);

         if First_Available in Reference_Index then
            Ref := Backend.Refs (First_Available);
         else
            raise Constraint_Error
              with "No non-empty unused reference in pool";
         end if;
      end Get;


      procedure Get
        (Constructor : not null access function return Held_Data;
         Ref : out Reference)
      is
         First_Available, First_Empty : Extended_Index;
      begin
         Backend.Find (First_Available, First_Empty);

         if First_Available in Reference_Index then
            Ref := Backend.Refs (First_Available);
         elsif First_Empty in Reference_Index then
            Backend.Refs (First_Empty) := Create (Constructor);
            Ref := Backend.Refs (First_Empty);
         else
            raise Constraint_Error with "No unused reference in pool";
         end if;
      end Get;


      procedure Create
        (Constructor : not null access function return Held_Data;
         Ref : out Reference;
         Expand_Count : in Pool_Size := 1)
      is
         First_Available, First_Empty : Extended_Index;
      begin
         Backend.Find (First_Available, First_Empty);

         if First_Available in Reference_Index then
            Ref := Backend.Refs (First_Available);

         elsif First_Empty in Reference_Index then
            Backend.Refs (First_Empty) := Create (Constructor);
            Ref := Backend.Refs (First_Empty);

         else
            First_Available := Backend.Length + 1;
            Backend.Preallocate (Expand_Count, Constructor);
            Ref := Backend.Refs (First_Available);
         end if;
      end Create;


      procedure Preallocate
        (New_Item_Count : in Pool_Size;
         Constructor : access function return Held_Data := null) is
      begin
         Backend.Preallocate (New_Item_Count, Constructor);
      end Preallocate;


      procedure Release_Unused is
      begin
         if Backend.Refs = null then
            return;
         end if;

         for I in Backend.Refs'Range loop
            if not Backend.Refs (I).Is_Empty
              and then Backend.Refs (I).Is_Last
            then
               Backend.Refs (I).Reset;
            end if;
         end loop;
      end Release_Unused;


      procedure Trim is
         Index : Extended_Index := 0;
         New_Count : constant Pool_Size := Initialized_Size;
         New_Data : Reference_Array_Access := null;
      begin
         if New_Count = Backend.Length then
            return;
         end if;

         New_Data := new Reference_Array (1 .. New_Count);

         for I in Backend.Refs'Range loop
            if not Backend.Refs (I).Is_Empty then
               Index := Index + 1;
               New_Data (Index) := Backend.Refs (I);
            end if;
         end loop;

         pragma Assert (Index = New_Count);

         Unchecked_Free (Backend.Refs);
         Backend.Refs := New_Data;
      exception
         when others =>
            Unchecked_Free (New_Data);
            raise;
      end Trim;


      procedure Purge is
      begin
         Release_Unused;
         Trim;
      end Purge;


      function Capacity return Pool_Size is
      begin
         return Backend.Length;
      end Capacity;


      function Initialized_Size return Pool_Size is
         Result : Pool_Size := 0;
      begin
         if Backend.Refs /= null then
            for I in Backend.Refs'Range loop
               if not Backend.Refs (I).Is_Empty then
                  Result := Result + 1;
               end if;
            end loop;
         end if;

         return Result;
      end Initialized_Size;


      function Active_Size return Pool_Size is
         Result : Pool_Size := 0;
      begin
         if Backend.Refs /= null then
            for I in Backend.Refs'Range loop
               if not Backend.Refs (I).Is_Empty
                 and then not Backend.Refs (I).Is_Last
               then
                  Result := Result + 1;
               end if;
            end loop;
         end if;

         return Result;
      end Active_Size;


      procedure Unchecked_Iterate
        (Process : not null access procedure (Ref : in Reference)) is
      begin
         for I in Backend.Refs'Range loop
            Process.all (Backend.Refs (I));
         end loop;
      end Unchecked_Iterate;

   end Pool;

end Natools.References.Pools;








Added src/natools-references-pools.ads version [788ce7a04c].












































































































































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

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

------------------------------------------------------------------------------
-- Copyright (c) 2014, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Natools.References.Pools provides a task-safe dynamic pool of            --
-- homogeneous references.                                                  --
------------------------------------------------------------------------------

private with Ada.Unchecked_Deallocation;

generic
package Natools.References.Pools is
   pragma Preelaborate;

   type Pool_Backend is limited private;
   pragma Preelaborable_Initialization (Pool_Backend);

   type Pool_Size is new Natural;

   protected type Pool is

      procedure Get (Ref : out Reference)
        with Post => not Ref.Is_Empty;
         --  Return an existing non-empty available reference from the pool,
         --  raising Constraint_Error when not possible.

      procedure Get
        (Constructor : not null access function return Held_Data;
         Ref : out Reference)
        with Post => not Ref.Is_Empty;
         --  Return an available reference from the pool, initializing it
         --  if needed, but without expanding the pool.
         --  Raise Constraint_Error when all references are in use.

      procedure Create
        (Constructor : not null access function return Held_Data;
         Ref : out Reference;
         Expand_Count : in Pool_Size := 1)
        with Pre => Expand_Count > 0, Post => not Ref.Is_Empty;
         --  Return a reference from the pool, creating it and/or initializing
         --  it if needed.

      procedure Preallocate
        (New_Item_Count : in Pool_Size;
         Constructor : access function return Held_Data := null);
         --  Add New_Item_Count references to the pool, using Constructor to
         --  initialize them if not null.

      procedure Release_Unused;
         --  Empty all references from the pool that are not used externally

      procedure Trim;
         --  Remove empty references from the pool, diminishing its capacity

      procedure Purge;
         --  Remove empty and available references from the pool.
         --  Equivalent to Release_Unused followed by Trim.

      function Capacity return Pool_Size;
         --  Return the number of references in the pool

      function Initialized_Size return Pool_Size;
         --  Return the number of non-empty references in the pool

      function Active_Size return Pool_Size;
         --  Return the number of externally-used references in the pool.
         --  WARNING: the result might be stale before it can be used by the
         --  client, do not take any sensitive decision from it.

      procedure Unchecked_Iterate
        (Process : not null access procedure (Ref : in Reference));
         --  Iterate over all references held in the pool.
         --  WARNING: Process must not call any potentially blocking operations
         --  or any operation on the current pool, and safety of any tampering
         --  with Ref or its referred object must be ensured independently.

   private
      Backend : Pool_Backend;
   end Pool;

private

   --  Basic types

   subtype Reference_Index is Pool_Size range 1 .. Pool_Size'Last;
   subtype Extended_Index is Pool_Size range 0 .. Pool_Size'Last;

   type Reference_Array is array (Reference_Index range <>) of Reference;

   type Reference_Array_Access is access Reference_Array;

   procedure Unchecked_Free is new Ada.Unchecked_Deallocation
     (Reference_Array, Reference_Array_Access);


   --  Dynamic array backend

   type Pool_Backend is new Ada.Finalization.Limited_Controlled with record
      Refs : Reference_Array_Access := null;
   end record;

   overriding procedure Finalize (Object : in out Pool_Backend);

   not overriding procedure Find
     (Container : in Pool_Backend;
      First_Available : out Extended_Index;
      First_Empty : out Extended_Index)
   with Post =>
     (First_Available = 0 or else
        (not Container.Refs (First_Available).Is_Empty
           and then Container.Refs (First_Available).Is_Last))
     and then (First_Empty = 0 or else Container.Refs (First_Empty).Is_Empty);

   not overriding function Length (Container : Pool_Backend) return Pool_Size
     is (if Container.Refs = null then 0 else Container.Refs'Length);

   not overriding procedure Preallocate
     (Container : in out Pool_Backend;
      New_Item_Count : in Pool_Size;
      Constructor : access function return Held_Data := null)
   with Post => (Container.Length = Container.Length'Old + New_Item_Count);

end Natools.References.Pools;













This page was generated in about
0.004s by
Fossil 2.23 [47362306a7] 2023-11-01 18:56:47