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-2003 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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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.Storage_Elements;
  35 with System.Soft_Links;
  36
  37 with Unchecked_Conversion;
  38
  39 package body System.Pool_Size is
  40
  41    package SSE renames System.Storage_Elements;
  42    use type SSE.Storage_Offset;
  43
  44    --  Even though these storage pools are typically only used
  45    --  by a single task, if multiple tasks are declared at the
  46    --  same or a more nested scope as the storage pool, there
  47    --  still may be concurrent access. The current implementation
  48    --  of Stack_Bounded_Pool always uses a global lock for protecting
  49    --  access. This should eventually be replaced by an atomic
  50    --  linked list implementation for efficiency reasons.
  51
  52    package SSL renames System.Soft_Links;
  53
  54    type Storage_Count_Access is access SSE.Storage_Count;
  55    function To_Storage_Count_Access is
  56      new Unchecked_Conversion (Address, Storage_Count_Access);
  57
  58    SC_Size : constant :=  SSE.Storage_Count'Object_Size / System.Storage_Unit;
  59
  60    package Variable_Size_Management is
  61
  62       --  Embedded pool that manages allocation of variable-size data.
  63
  64       --  This pool is used as soon as the Elmt_sizS of the pool object is 0.
  65
  66       --  Allocation is done on the first chunk long enough for the request.
  67       --  Deallocation just puts the freed chunk at the beginning of the list.
  68
  69       procedure Initialize  (Pool : in out Stack_Bounded_Pool);
  70       procedure Allocate
  71         (Pool         : in out Stack_Bounded_Pool;
  72          Address      : out System.Address;
  73          Storage_Size : SSE.Storage_Count;
  74          Alignment    : SSE.Storage_Count);
  75
  76       procedure Deallocate
  77         (Pool         : in out Stack_Bounded_Pool;
  78          Address      : System.Address;
  79          Storage_Size : SSE.Storage_Count;
  80          Alignment    : SSE.Storage_Count);
  81    end Variable_Size_Management;
  82
  83    package Vsize renames Variable_Size_Management;
  84
  85    --------------
  86    -- Allocate --
  87    --------------
  88
  89    procedure Allocate
  90      (Pool         : in out Stack_Bounded_Pool;
  91       Address      : out System.Address;
  92       Storage_Size : SSE.Storage_Count;
  93       Alignment    : SSE.Storage_Count)
  94    is
  95    begin
  96       SSL.Lock_Task.all;
  97
  98       if Pool.Elmt_Size = 0 then
  99          Vsize.Allocate (Pool, Address, Storage_Size, Alignment);
 100
 101       elsif Pool.First_Free /= 0 then
 102          Address := Pool.The_Pool (Pool.First_Free)'Address;
 103          Pool.First_Free := To_Storage_Count_Access (Address).all;
 104
 105       elsif
 106         Pool.First_Empty <= (Pool.Pool_Size - Pool.Aligned_Elmt_Size + 1)
 107       then
 108          Address := Pool.The_Pool (Pool.First_Empty)'Address;
 109          Pool.First_Empty := Pool.First_Empty + Pool.Aligned_Elmt_Size;
 110
 111       else
 112          raise Storage_Error;
 113       end if;
 114
 115       SSL.Unlock_Task.all;
 116
 117    exception
 118       when others =>
 119          SSL.Unlock_Task.all;
 120          raise;
 121    end Allocate;
 122
 123    ----------------
 124    -- Deallocate --
 125    ----------------
 126
 127    procedure Deallocate
 128      (Pool         : in out Stack_Bounded_Pool;
 129       Address      : System.Address;
 130       Storage_Size : SSE.Storage_Count;
 131       Alignment    : SSE.Storage_Count)
 132    is
 133    begin
 134       SSL.Lock_Task.all;
 135
 136       if Pool.Elmt_Size = 0 then
 137          Vsize.Deallocate (Pool, Address, Storage_Size, Alignment);
 138
 139       else
 140          To_Storage_Count_Access (Address).all := Pool.First_Free;
 141          Pool.First_Free := Address - Pool.The_Pool'Address + 1;
 142       end if;
 143
 144       SSL.Unlock_Task.all;
 145    exception
 146       when others =>
 147          SSL.Unlock_Task.all;
 148          raise;
 149    end Deallocate;
 150
 151    ----------------
 152    -- Initialize --
 153    ----------------
 154
 155    procedure Initialize  (Pool : in out Stack_Bounded_Pool) is
 156       Align : constant SSE.Storage_Count :=
 157         SSE.Storage_Count'Max (SSE.Storage_Count'Alignment, Pool.Alignment);
 158
 159    begin
 160       if Pool.Elmt_Size = 0 then
 161          Vsize.Initialize (Pool);
 162
 163       else
 164          Pool.First_Free := 0;
 165          Pool.First_Empty := 1;
 166
 167          --  Compute the size to allocate given the size of the element and
 168          --  the possible Alignment clause
 169
 170          Pool.Aligned_Elmt_Size :=
 171            SSE.Storage_Count'Max (SC_Size,
 172              ((Pool.Elmt_Size + Align - 1) / Align) * Align);
 173       end if;
 174    end Initialize;
 175
 176    ------------------
 177    -- Storage_Size --
 178    ------------------
 179
 180    function  Storage_Size
 181      (Pool : Stack_Bounded_Pool)
 182       return SSE.Storage_Count
 183    is
 184    begin
 185       return Pool.Pool_Size;
 186    end Storage_Size;
 187
 188    ------------------------------
 189    -- Variable_Size_Management --
 190    ------------------------------
 191
 192    package body Variable_Size_Management is
 193
 194       Minimum_Size : constant := 2 * SC_Size;
 195
 196       procedure Set_Size
 197         (Pool        : Stack_Bounded_Pool;
 198          Chunk, Size : SSE.Storage_Count);
 199       --  Update the field 'size' of a chunk of available storage
 200
 201       procedure Set_Next
 202         (Pool        : Stack_Bounded_Pool;
 203          Chunk, Next : SSE.Storage_Count);
 204       --  Update the field 'next' of a chunk of available storage
 205
 206       function Size
 207         (Pool  : Stack_Bounded_Pool;
 208          Chunk : SSE.Storage_Count)
 209          return SSE.Storage_Count;
 210       --  Fetch the field 'size' of a chunk of available storage
 211
 212       function Next
 213         (Pool  : Stack_Bounded_Pool;
 214          Chunk : SSE.Storage_Count)
 215          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)
 221          return SSE.Storage_Count;
 222       --  Give the chunk number in the pool from its Address
 223
 224       --------------
 225       -- Allocate --
 226       --------------
 227
 228       procedure Allocate
 229         (Pool         : in out Stack_Bounded_Pool;
 230          Address      : out System.Address;
 231          Storage_Size : SSE.Storage_Count;
 232          Alignment    : SSE.Storage_Count)
 233       is
 234          Chunk      : SSE.Storage_Count;
 235          New_Chunk  : SSE.Storage_Count;
 236          Prev_Chunk : SSE.Storage_Count;
 237          Our_Align  : constant SSE.Storage_Count :=
 238                         SSE.Storage_Count'Max (SSE.Storage_Count'Alignment,
 239                                                Alignment);
 240          Align_Size : constant SSE.Storage_Count :=
 241                         SSE.Storage_Count'Max (
 242                           Minimum_Size,
 243                           ((Storage_Size + Our_Align - 1) / Our_Align) *
 244                                                                   Our_Align);
 245
 246       begin
 247          --  Look for the first big enough chunk
 248
 249          Prev_Chunk := Pool.First_Free;
 250          Chunk := Next (Pool, Prev_Chunk);
 251
 252          while Chunk /= 0 and then Size (Pool, Chunk) < Align_Size loop
 253             Prev_Chunk := Chunk;
 254             Chunk := Next (Pool, Chunk);
 255          end loop;
 256
 257          --  Raise storage_error if no big enough chunk available
 258
 259          if Chunk = 0 then
 260             raise Storage_Error;
 261          end if;
 262
 263          --  When the chunk is bigger than what is needed, take appropraite
 264          --  amount and build a new shrinked chunk with the remainder.
 265
 266          if Size (Pool, Chunk) - Align_Size  > Minimum_Size then
 267             New_Chunk := Chunk + Align_Size;
 268             Set_Size (Pool, New_Chunk, Size (Pool, Chunk) - Align_Size);
 269             Set_Next (Pool, New_Chunk, Next (Pool, Chunk));
 270             Set_Next (Pool, Prev_Chunk, New_Chunk);
 271
 272          --  If the chunk is the right size, just delete it from the chain
 273
 274          else
 275             Set_Next (Pool, Prev_Chunk, Next (Pool, Chunk));
 276          end if;
 277
 278          Address := Pool.The_Pool (Chunk)'Address;
 279       end Allocate;
 280
 281       --------------
 282       -- Chunk_Of --
 283       --------------
 284
 285       function Chunk_Of
 286         (Pool : Stack_Bounded_Pool;
 287          Addr : System.Address)
 288          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          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)
 343          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)
 401          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;