/usr/share/ada/adainclude/gnatcoll/gnatcoll-pools.adb is in libgnatcoll1.6-dev 1.6gpl2014-9.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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 357 358 359 360 361 362 363 | ------------------------------------------------------------------------------
-- M O D E L I N G --
-- --
-- Copyright (C) 2010-2014, 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.Refcount.Weakref; use GNATCOLL.Refcount.Weakref;
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 : Pointers.Encapsulated_Access;
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 := new Resource_Data'
(Weak_Refcounted with
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 := new Resource_Data'
(Weak_Refcounted with
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 : constant Encapsulated_Access := Get (Self);
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
W : Weak_Ref;
begin
W := Get_Weak_Ref (Self);
return Weak_Resource'(Ref => W);
end Get_Weak;
---------
-- Get --
---------
procedure Get (Self : Weak_Resource; Res : out Resource'Class) is
begin
Get (Self.Ref, Res);
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 --
----------
overriding procedure Free (Self : in out Resource_Data) is
begin
Free (Weak_Refcounted (Self));
-- 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 --
------------------
overriding function Get_Refcount (Self : Resource) return Natural is
begin
return Pointers.Pointers.Get_Refcount (Pointers.Pointers.Ref (Self));
end Get_Refcount;
end GNATCOLL.Pools;
|