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