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