gcc/ada/s-poosiz.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                     S Y S T E M . P O O L _ S I Z E                      --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT 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 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with System.Soft_Links;
  33
  34 with Ada.Unchecked_Conversion;
  35
  36 package body System.Pool_Size is
  37
  38    package SSE renames System.Storage_Elements;
  39    use type SSE.Storage_Offset;
  40
  41    --  Even though these storage pools are typically only used by a single
  42    --  task, if multiple tasks are declared at the same or a more nested scope
  43    --  as the storage pool, there still may be concurrent access. The current
  44    --  implementation of Stack_Bounded_Pool always uses a global lock for
  45    --  protecting access. This should eventually be replaced by an atomic
  46    --  linked list implementation for efficiency reasons.
  47
  48    package SSL renames System.Soft_Links;
  49
  50    type Storage_Count_Access is access SSE.Storage_Count;
  51    function To_Storage_Count_Access is
  52      new Ada.Unchecked_Conversion (Address, Storage_Count_Access);
  53
  54    SC_Size : constant :=  SSE.Storage_Count'Object_Size / System.Storage_Unit;
  55
  56    package Variable_Size_Management is
  57
  58       --  Embedded pool that manages allocation of variable-size data
  59
  60       --  This pool is used as soon as the Elmt_Size of the pool object is 0
  61
  62       --  Allocation is done on the first chunk long enough for the request.
  63       --  Deallocation just puts the freed chunk at the beginning of the list.
  64
  65       procedure Initialize  (Pool : in out Stack_Bounded_Pool);
  66       procedure Allocate
  67         (Pool         : in out Stack_Bounded_Pool;
  68          Address      : out System.Address;
  69          Storage_Size : SSE.Storage_Count;
  70          Alignment    : SSE.Storage_Count);
  71
  72       procedure Deallocate
  73         (Pool         : in out Stack_Bounded_Pool;
  74          Address      : System.Address;
  75          Storage_Size : SSE.Storage_Count;
  76          Alignment    : SSE.Storage_Count);
  77    end Variable_Size_Management;
  78
  79    package Vsize renames Variable_Size_Management;
  80
  81    --------------
  82    -- Allocate --
  83    --------------
  84
  85    procedure Allocate
  86      (Pool         : in out Stack_Bounded_Pool;
  87       Address      : out System.Address;
  88       Storage_Size : SSE.Storage_Count;
  89       Alignment    : SSE.Storage_Count)
  90    is
  91    begin
  92       SSL.Lock_Task.all;
  93
  94       if Pool.Elmt_Size = 0 then
  95          Vsize.Allocate (Pool, Address, Storage_Size, Alignment);
  96
  97       elsif Pool.First_Free /= 0 then
  98          Address := Pool.The_Pool (Pool.First_Free)'Address;
  99          Pool.First_Free := To_Storage_Count_Access (Address).all;
 100
 101       elsif
 102         Pool.First_Empty <= (Pool.Pool_Size - Pool.Aligned_Elmt_Size + 1)
 103       then
 104          Address := Pool.The_Pool (Pool.First_Empty)'Address;
 105          Pool.First_Empty := Pool.First_Empty + Pool.Aligned_Elmt_Size;
 106
 107       else
 108          raise Storage_Error;
 109       end if;
 110
 111       SSL.Unlock_Task.all;
 112
 113    exception
 114       when others =>
 115          SSL.Unlock_Task.all;
 116          raise;
 117    end Allocate;
 118
 119    ----------------
 120    -- Deallocate --
 121    ----------------
 122
 123    procedure Deallocate
 124      (Pool         : in out Stack_Bounded_Pool;
 125       Address      : System.Address;
 126       Storage_Size : SSE.Storage_Count;
 127       Alignment    : SSE.Storage_Count)
 128    is
 129    begin
 130       SSL.Lock_Task.all;
 131
 132       if Pool.Elmt_Size = 0 then
 133          Vsize.Deallocate (Pool, Address, Storage_Size, Alignment);
 134
 135       else
 136          To_Storage_Count_Access (Address).all := Pool.First_Free;
 137          Pool.First_Free := Address - Pool.The_Pool'Address + 1;
 138       end if;
 139
 140       SSL.Unlock_Task.all;
 141    exception
 142       when others =>
 143          SSL.Unlock_Task.all;
 144          raise;
 145    end Deallocate;
 146
 147    ----------------
 148    -- Initialize --
 149    ----------------
 150
 151    procedure Initialize  (Pool : in out Stack_Bounded_Pool) is
 152
 153       --  Define the appropriate alignment for allocations. This is the
 154       --  maximum of the requested alignment, and the alignment required
 155       --  for Storage_Count values. The latter test is to ensure that we
 156       --  can properly reference the linked list pointers for free lists.
 157
 158       Align : constant SSE.Storage_Count :=
 159                 SSE.Storage_Count'Max
 160                   (SSE.Storage_Count'Alignment, Pool.Alignment);
 161
 162    begin
 163       if Pool.Elmt_Size = 0 then
 164          Vsize.Initialize (Pool);
 165
 166       else
 167          Pool.First_Free := 0;
 168          Pool.First_Empty := 1;
 169
 170          --  Compute the size to allocate given the size of the element and
 171          --  the possible alignment requirement as defined above.
 172
 173          Pool.Aligned_Elmt_Size :=
 174            SSE.Storage_Count'Max (SC_Size,
 175              ((Pool.Elmt_Size + Align - 1) / Align) * Align);
 176       end if;
 177    end Initialize;
 178
 179    ------------------
 180    -- Storage_Size --
 181    ------------------
 182
 183    function  Storage_Size
 184      (Pool : Stack_Bounded_Pool) return SSE.Storage_Count
 185    is
 186    begin
 187       return Pool.Pool_Size;
 188    end Storage_Size;
 189
 190    ------------------------------
 191    -- Variable_Size_Management --
 192    ------------------------------
 193
 194    package body Variable_Size_Management is
 195
 196       Minimum_Size : constant := 2 * SC_Size;
 197
 198       procedure Set_Size
 199         (Pool        : Stack_Bounded_Pool;
 200          Chunk, Size : SSE.Storage_Count);
 201       --  Update the field 'size' of a chunk of available storage
 202
 203       procedure Set_Next
 204         (Pool        : Stack_Bounded_Pool;
 205          Chunk, Next : SSE.Storage_Count);
 206       --  Update the field 'next' of a chunk of available storage
 207
 208       function Size
 209         (Pool  : Stack_Bounded_Pool;
 210          Chunk : SSE.Storage_Count) return SSE.Storage_Count;
 211       --  Fetch the field 'size' of a chunk of available storage
 212
 213       function Next
 214         (Pool  : Stack_Bounded_Pool;
 215          Chunk : SSE.Storage_Count) return SSE.Storage_Count;
 216       --  Fetch the field 'next' of a chunk of available storage
 217
 218       function Chunk_Of
 219         (Pool : Stack_Bounded_Pool;
 220          Addr : System.Address) return SSE.Storage_Count;
 221       --  Give the chunk number in the pool from its Address
 222
 223       --------------
 224       -- Allocate --
 225       --------------
 226
 227       procedure Allocate
 228         (Pool         : in out Stack_Bounded_Pool;
 229          Address      : out System.Address;
 230          Storage_Size : SSE.Storage_Count;
 231          Alignment    : SSE.Storage_Count)
 232       is
 233          Chunk      : SSE.Storage_Count;
 234          New_Chunk  : SSE.Storage_Count;
 235          Prev_Chunk : SSE.Storage_Count;
 236          Our_Align  : constant SSE.Storage_Count :=
 237                         SSE.Storage_Count'Max (SSE.Storage_Count'Alignment,
 238                                                Alignment);
 239          Align_Size : constant SSE.Storage_Count :=
 240                         SSE.Storage_Count'Max (
 241                           Minimum_Size,
 242                           ((Storage_Size + Our_Align - 1) / Our_Align) *
 243                                                                   Our_Align);
 244
 245       begin
 246          --  Look for the first big enough chunk
 247
 248          Prev_Chunk := Pool.First_Free;
 249          Chunk := Next (Pool, Prev_Chunk);
 250
 251          while Chunk /= 0 and then Size (Pool, Chunk) < Align_Size loop
 252             Prev_Chunk := Chunk;
 253             Chunk := Next (Pool, Chunk);
 254          end loop;
 255
 256          --  Raise storage_error if no big enough chunk available
 257
 258          if Chunk = 0 then
 259             raise Storage_Error;
 260          end if;
 261
 262          --  When the chunk is bigger than what is needed, take appropriate
 263          --  amount and build a new shrinked chunk with the remainder.
 264
 265          if Size (Pool, Chunk) - Align_Size  > Minimum_Size then
 266             New_Chunk := Chunk + Align_Size;
 267             Set_Size (Pool, New_Chunk, Size (Pool, Chunk) - Align_Size);
 268             Set_Next (Pool, New_Chunk, Next (Pool, Chunk));
 269             Set_Next (Pool, Prev_Chunk, New_Chunk);
 270
 271          --  If the chunk is the right size, just delete it from the chain
 272
 273          else
 274             Set_Next (Pool, Prev_Chunk, Next (Pool, Chunk));
 275          end if;
 276
 277          Address := Pool.The_Pool (Chunk)'Address;
 278       end Allocate;
 279
 280       --------------
 281       -- Chunk_Of --
 282       --------------
 283
 284       function Chunk_Of
 285         (Pool : Stack_Bounded_Pool;
 286          Addr : System.Address) return SSE.Storage_Count
 287       is
 288       begin
 289          return 1 + abs (Addr - Pool.The_Pool (1)'Address);
 290       end Chunk_Of;
 291
 292       ----------------
 293       -- Deallocate --
 294       ----------------
 295
 296       procedure Deallocate
 297         (Pool         : in out Stack_Bounded_Pool;
 298          Address      : System.Address;
 299          Storage_Size : SSE.Storage_Count;
 300          Alignment    : SSE.Storage_Count)
 301       is
 302          pragma Warnings (Off, Pool);
 303
 304          Align_Size : constant SSE.Storage_Count :=
 305                         ((Storage_Size + Alignment - 1) / Alignment) *
 306                                                                  Alignment;
 307          Chunk : constant SSE.Storage_Count := Chunk_Of (Pool, Address);
 308
 309       begin
 310          --  Attach the freed chunk to the chain
 311
 312          Set_Size (Pool, Chunk,
 313                          SSE.Storage_Count'Max (Align_Size, Minimum_Size));
 314          Set_Next (Pool, Chunk, Next (Pool, Pool.First_Free));
 315          Set_Next (Pool, Pool.First_Free,  Chunk);
 316
 317       end Deallocate;
 318
 319       ----------------
 320       -- Initialize --
 321       ----------------
 322
 323       procedure Initialize  (Pool : in out Stack_Bounded_Pool) is
 324       begin
 325          Pool.First_Free := 1;
 326
 327          if Pool.Pool_Size > Minimum_Size then
 328             Set_Next (Pool, Pool.First_Free, Pool.First_Free + Minimum_Size);
 329             Set_Size (Pool, Pool.First_Free, 0);
 330             Set_Size (Pool, Pool.First_Free + Minimum_Size,
 331                                               Pool.Pool_Size - Minimum_Size);
 332             Set_Next (Pool, Pool.First_Free + Minimum_Size, 0);
 333          end if;
 334       end Initialize;
 335
 336       ----------
 337       -- Next --
 338       ----------
 339
 340       function Next
 341         (Pool  : Stack_Bounded_Pool;
 342          Chunk : SSE.Storage_Count) return SSE.Storage_Count
 343       is
 344       begin
 345          pragma Warnings (Off);
 346          --  Kill alignment warnings, we are careful to make sure
 347          --  that the alignment is correct.
 348
 349          return To_Storage_Count_Access
 350                   (Pool.The_Pool (Chunk + SC_Size)'Address).all;
 351
 352          pragma Warnings (On);
 353       end Next;
 354
 355       --------------
 356       -- Set_Next --
 357       --------------
 358
 359       procedure Set_Next
 360         (Pool        : Stack_Bounded_Pool;
 361          Chunk, Next : SSE.Storage_Count)
 362       is
 363       begin
 364          pragma Warnings (Off);
 365          --  Kill alignment warnings, we are careful to make sure
 366          --  that the alignment is correct.
 367
 368          To_Storage_Count_Access
 369            (Pool.The_Pool (Chunk + SC_Size)'Address).all := Next;
 370
 371          pragma Warnings (On);
 372       end Set_Next;
 373
 374       --------------
 375       -- Set_Size --
 376       --------------
 377
 378       procedure Set_Size
 379         (Pool        : Stack_Bounded_Pool;
 380          Chunk, Size : SSE.Storage_Count)
 381       is
 382       begin
 383          pragma Warnings (Off);
 384          --  Kill alignment warnings, we are careful to make sure
 385          --  that the alignment is correct.
 386
 387          To_Storage_Count_Access
 388            (Pool.The_Pool (Chunk)'Address).all := Size;
 389
 390          pragma Warnings (On);
 391       end Set_Size;
 392
 393       ----------
 394       -- Size --
 395       ----------
 396
 397       function Size
 398         (Pool  : Stack_Bounded_Pool;
 399          Chunk : SSE.Storage_Count) return SSE.Storage_Count
 400       is
 401       begin
 402          pragma Warnings (Off);
 403          --  Kill alignment warnings, we are careful to make sure
 404          --  that the alignment is correct.
 405
 406          return To_Storage_Count_Access (Pool.The_Pool (Chunk)'Address).all;
 407
 408          pragma Warnings (On);
 409       end Size;
 410
 411    end  Variable_Size_Management;
 412 end System.Pool_Size;