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