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