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 --                                                                          --
  10 --          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNAT was originally developed  by the GNAT team at  New York University. --
  31 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 with System.Storage_Elements;
  36 with System.Address_To_Access_Conversions;
  37
  38 package body System.Pool_Size is
  39
  40    package SSE renames System.Storage_Elements;
  41    use type SSE.Storage_Offset;
  42
  43    package SC is new Address_To_Access_Conversions (SSE.Storage_Count);
  44
  45    SC_Size : constant
  46      :=  SSE.Storage_Count'Object_Size / System.Storage_Unit;
  47
  48    package Variable_Size_Management is
  49
  50       --  Embedded pool that manages allocation of variable-size data.
  51
  52       --  This pool is used as soon as the Elmt_sizS of the pool object is 0.
  53
  54       --  Allocation is done on the first chunk long enough for the request.
  55       --  Deallocation just puts the freed chunk at the beginning of the list.
  56
  57       procedure Initialize  (Pool : in out Stack_Bounded_Pool);
  58       procedure Allocate
  59         (Pool         : in out Stack_Bounded_Pool;
  60          Address      : out System.Address;
  61          Storage_Size : SSE.Storage_Count;
  62          Alignment    : SSE.Storage_Count);
  63
  64       procedure Deallocate
  65         (Pool         : in out Stack_Bounded_Pool;
  66          Address      : System.Address;
  67          Storage_Size : SSE.Storage_Count;
  68          Alignment    : SSE.Storage_Count);
  69    end Variable_Size_Management;
  70
  71    package Vsize renames Variable_Size_Management;
  72
  73    --------------
  74    -- Allocate --
  75    --------------
  76
  77    procedure Allocate
  78      (Pool         : in out Stack_Bounded_Pool;
  79       Address      : out System.Address;
  80       Storage_Size : SSE.Storage_Count;
  81       Alignment    : SSE.Storage_Count)
  82    is
  83    begin
  84       if Pool.Elmt_Size = 0 then
  85          Vsize.Allocate (Pool, Address, Storage_Size, Alignment);
  86
  87       elsif Pool.First_Free /= 0 then
  88          Address := Pool.The_Pool (Pool.First_Free)'Address;
  89          Pool.First_Free := SC.To_Pointer (Address).all;
  90
  91       elsif
  92         Pool.First_Empty <= (Pool.Pool_Size - Pool.Aligned_Elmt_Size + 1)
  93       then
  94          Address := Pool.The_Pool (Pool.First_Empty)'Address;
  95          Pool.First_Empty := Pool.First_Empty + Pool.Aligned_Elmt_Size;
  96
  97       else
  98          raise Storage_Error;
  99       end if;
 100    end Allocate;
 101
 102    ----------------
 103    -- Deallocate --
 104    ----------------
 105
 106    procedure Deallocate
 107      (Pool         : in out Stack_Bounded_Pool;
 108       Address      : System.Address;
 109       Storage_Size : SSE.Storage_Count;
 110       Alignment    : SSE.Storage_Count)
 111    is
 112    begin
 113       if Pool.Elmt_Size = 0 then
 114          Vsize.Deallocate (Pool, Address, Storage_Size, Alignment);
 115
 116       else
 117          SC.To_Pointer (Address).all := Pool.First_Free;
 118          Pool.First_Free := Address - Pool.The_Pool'Address + 1;
 119       end if;
 120    end Deallocate;
 121
 122    ----------------
 123    -- Initialize --
 124    ----------------
 125
 126    procedure Initialize  (Pool : in out Stack_Bounded_Pool) is
 127       Align : constant SSE.Storage_Count :=
 128         SSE.Storage_Count'Max (SSE.Storage_Count'Alignment, Pool.Alignment);
 129
 130    begin
 131       if Pool.Elmt_Size = 0 then
 132          Vsize.Initialize (Pool);
 133
 134       else
 135          Pool.First_Free := 0;
 136          Pool.First_Empty := 1;
 137
 138          --  Compute the size to allocate given the size of the element and
 139          --  the possible Alignment clause
 140
 141          Pool.Aligned_Elmt_Size :=
 142            SSE.Storage_Count'Max (SC_Size,
 143              ((Pool.Elmt_Size + Align - 1) / Align) * Align);
 144       end if;
 145    end Initialize;
 146
 147    ------------------
 148    -- Storage_Size --
 149    ------------------
 150
 151    function  Storage_Size
 152      (Pool : Stack_Bounded_Pool)
 153       return SSE.Storage_Count
 154    is
 155    begin
 156       return Pool.Pool_Size;
 157    end Storage_Size;
 158
 159    ------------------------------
 160    -- Variable_Size_Management --
 161    ------------------------------
 162
 163    package body Variable_Size_Management is
 164
 165       Minimum_Size : constant := 2 * SC_Size;
 166
 167       procedure Set_Size
 168         (Pool        : Stack_Bounded_Pool;
 169          Chunk, Size : SSE.Storage_Count);
 170       --  Update the field 'size' of a chunk of available storage
 171
 172       procedure Set_Next
 173         (Pool        : Stack_Bounded_Pool;
 174          Chunk, Next : SSE.Storage_Count);
 175       --  Update the field 'next' of a chunk of available storage
 176
 177       function Size
 178         (Pool  : Stack_Bounded_Pool;
 179          Chunk : SSE.Storage_Count)
 180          return SSE.Storage_Count;
 181       --  Fetch the field 'size' of a chunk of available storage
 182
 183       function Next
 184         (Pool  : Stack_Bounded_Pool;
 185          Chunk : SSE.Storage_Count)
 186          return  SSE.Storage_Count;
 187       --  Fetch the field 'next' of a chunk of available storage
 188
 189       function Chunk_Of
 190         (Pool : Stack_Bounded_Pool;
 191          Addr : System.Address)
 192          return SSE.Storage_Count;
 193       --  Give the chunk number in the pool from its Address
 194
 195       --------------
 196       -- Allocate --
 197       --------------
 198
 199       procedure Allocate
 200         (Pool         : in out Stack_Bounded_Pool;
 201          Address      : out System.Address;
 202          Storage_Size : SSE.Storage_Count;
 203          Alignment    : SSE.Storage_Count)
 204       is
 205          Chunk      : SSE.Storage_Count;
 206          New_Chunk  : SSE.Storage_Count;
 207          Prev_Chunk : SSE.Storage_Count;
 208          Our_Align  : constant SSE.Storage_Count :=
 209                         SSE.Storage_Count'Max (SSE.Storage_Count'Alignment,
 210                                                Alignment);
 211          Align_Size : constant SSE.Storage_Count :=
 212                         SSE.Storage_Count'Max (
 213                           Minimum_Size,
 214                           ((Storage_Size + Our_Align - 1) / Our_Align) *
 215                                                                   Our_Align);
 216
 217       begin
 218          --  Look for the first big enough chunk
 219
 220          Prev_Chunk := Pool.First_Free;
 221          Chunk := Next (Pool, Prev_Chunk);
 222
 223          while Chunk /= 0 and then Size (Pool, Chunk) < Align_Size loop
 224             Prev_Chunk := Chunk;
 225             Chunk := Next (Pool, Chunk);
 226          end loop;
 227
 228          --  Raise storage_error if no big enough chunk available
 229
 230          if Chunk = 0 then
 231             raise Storage_Error;
 232          end if;
 233
 234          --  When the chunk is bigger than what is needed, take appropraite
 235          --  amount and build a new shrinked chunk with the remainder.
 236
 237          if Size (Pool, Chunk) - Align_Size  > Minimum_Size then
 238             New_Chunk := Chunk + Align_Size;
 239             Set_Size (Pool, New_Chunk, Size (Pool, Chunk) - Align_Size);
 240             Set_Next (Pool, New_Chunk, Next (Pool, Chunk));
 241             Set_Next (Pool, Prev_Chunk, New_Chunk);
 242
 243          --  If the chunk is the right size, just delete it from the chain
 244
 245          else
 246             Set_Next (Pool, Prev_Chunk, Next (Pool, Chunk));
 247          end if;
 248
 249          Address := Pool.The_Pool (Chunk)'Address;
 250       end Allocate;
 251
 252       --------------
 253       -- Chunk_Of --
 254       --------------
 255
 256       function Chunk_Of
 257         (Pool : Stack_Bounded_Pool;
 258          Addr : System.Address)
 259          return SSE.Storage_Count
 260       is
 261       begin
 262          return 1 + abs (Addr - Pool.The_Pool (1)'Address);
 263       end Chunk_Of;
 264
 265       ----------------
 266       -- Deallocate --
 267       ----------------
 268
 269       procedure Deallocate
 270         (Pool         : in out Stack_Bounded_Pool;
 271          Address      : System.Address;
 272          Storage_Size : SSE.Storage_Count;
 273          Alignment    : SSE.Storage_Count)
 274       is
 275          Align_Size : constant SSE.Storage_Count :=
 276                         ((Storage_Size + Alignment - 1) / Alignment) *
 277                                                                  Alignment;
 278          Chunk : SSE.Storage_Count := Chunk_Of (Pool, Address);
 279
 280       begin
 281          --  Attach the freed chunk to the chain
 282
 283          Set_Size (Pool, Chunk,
 284                          SSE.Storage_Count'Max (Align_Size, Minimum_Size));
 285          Set_Next (Pool, Chunk, Next (Pool, Pool.First_Free));
 286          Set_Next (Pool, Pool.First_Free,  Chunk);
 287
 288       end Deallocate;
 289
 290       ----------------
 291       -- Initialize --
 292       ----------------
 293
 294       procedure Initialize  (Pool : in out Stack_Bounded_Pool) is
 295       begin
 296          Pool.First_Free := 1;
 297
 298          if Pool.Pool_Size > Minimum_Size then
 299             Set_Next (Pool, Pool.First_Free, Pool.First_Free + Minimum_Size);
 300             Set_Size (Pool, Pool.First_Free, 0);
 301             Set_Size (Pool, Pool.First_Free + Minimum_Size,
 302                                               Pool.Pool_Size - Minimum_Size);
 303             Set_Next (Pool, Pool.First_Free + Minimum_Size, 0);
 304          end if;
 305       end Initialize;
 306
 307       ----------
 308       -- Next --
 309       ----------
 310
 311       function Next
 312         (Pool  : Stack_Bounded_Pool;
 313          Chunk : SSE.Storage_Count)
 314          return  SSE.Storage_Count
 315       is
 316       begin
 317          return SC.To_Pointer (Pool.The_Pool (Chunk + SC_Size)'Address).all;
 318       end Next;
 319
 320       --------------
 321       -- Set_Next --
 322       --------------
 323
 324       procedure Set_Next
 325         (Pool        : Stack_Bounded_Pool;
 326          Chunk, Next : SSE.Storage_Count)
 327       is
 328       begin
 329          SC.To_Pointer (Pool.The_Pool (Chunk + SC_Size)'Address).all := Next;
 330       end Set_Next;
 331
 332       --------------
 333       -- Set_Size --
 334       --------------
 335
 336       procedure Set_Size
 337         (Pool        : Stack_Bounded_Pool;
 338          Chunk, Size : SSE.Storage_Count)
 339       is
 340       begin
 341          SC.To_Pointer (Pool.The_Pool (Chunk)'Address).all := Size;
 342       end Set_Size;
 343
 344       ----------
 345       -- Size --
 346       ----------
 347
 348       function Size
 349         (Pool  : Stack_Bounded_Pool;
 350          Chunk : SSE.Storage_Count)
 351          return  SSE.Storage_Count
 352       is
 353       begin
 354          return  SC.To_Pointer (Pool.The_Pool (Chunk)'Address).all;
 355       end Size;
 356
 357    end  Variable_Size_Management;
 358 end System.Pool_Size;