gcc/ada/libgnat/s-pooglo.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                   S Y S T E M . P O O L _ G L O B A L                    --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2024, 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 3,  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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with System.Storage_Pools; use System.Storage_Pools;
  33 with System.Memory;
  34
  35 package body System.Pool_Global is
  36
  37    package SSE renames System.Storage_Elements;
  38
  39    --------------
  40    -- Allocate --
  41    --------------
  42
  43    overriding procedure Allocate
  44      (Pool         : in out Unbounded_No_Reclaim_Pool;
  45       Address      : out System.Address;
  46       Storage_Size : SSE.Storage_Count;
  47       Alignment    : SSE.Storage_Count)
  48    is
  49       use SSE;
  50       pragma Warnings (Off, Pool);
  51
  52       Aligned_Size    : Storage_Count := Storage_Size;
  53       Aligned_Address : System.Address;
  54       Allocated       : System.Address;
  55
  56    begin
  57       if Alignment > Standard'System_Allocator_Alignment then
  58          Aligned_Size := Aligned_Size + Alignment;
  59       end if;
  60
  61       Allocated := Memory.Alloc (Memory.size_t (Aligned_Size));
  62
  63       --  The call to Alloc returns an address whose alignment is compatible
  64       --  with the worst case alignment requirement for the machine; thus the
  65       --  Alignment argument can be safely ignored.
  66
  67       if Allocated = Null_Address then
  68          raise Storage_Error;
  69       end if;
  70
  71       --  Case where alignment requested is greater than the alignment that is
  72       --  guaranteed to be provided by the system allocator.
  73
  74       if Alignment > Standard'System_Allocator_Alignment then
  75
  76          --  Realign the returned address
  77
  78          Aligned_Address :=
  79            Allocated + Alignment
  80            - Storage_Offset (To_Integer (Allocated)
  81                              mod Integer_Address (Alignment));
  82
  83          --  Save the block address
  84
  85          declare
  86             Saved_Address : System.Address;
  87             pragma Import (Ada, Saved_Address);
  88             for Saved_Address'Address use
  89                Aligned_Address
  90                - Storage_Offset (System.Address'Size / Storage_Unit);
  91          begin
  92             Saved_Address := Allocated;
  93          end;
  94
  95          Address := Aligned_Address;
  96
  97       else
  98          Address := Allocated;
  99       end if;
 100    end Allocate;
 101
 102    ----------------
 103    -- Deallocate --
 104    ----------------
 105
 106    overriding procedure Deallocate
 107      (Pool         : in out Unbounded_No_Reclaim_Pool;
 108       Address      : System.Address;
 109       Storage_Size : SSE.Storage_Count;
 110       Alignment    : SSE.Storage_Count)
 111    is
 112       use System.Storage_Elements;
 113       pragma Warnings (Off, Pool);
 114       pragma Warnings (Off, Storage_Size);
 115
 116    begin
 117       --  Case where the alignment of the block exceeds the guaranteed
 118       --  alignment required by the system storage allocator, meaning that
 119       --  this was specially wrapped at allocation time.
 120
 121       if Alignment > Standard'System_Allocator_Alignment then
 122
 123          --  Retrieve the block address
 124
 125          declare
 126             Saved_Address : System.Address;
 127             pragma Import (Ada, Saved_Address);
 128             for Saved_Address'Address use
 129               Address - Storage_Offset (System.Address'Size / Storage_Unit);
 130          begin
 131             Memory.Free (Saved_Address);
 132          end;
 133
 134       else
 135          Memory.Free (Address);
 136       end if;
 137    end Deallocate;
 138
 139    ------------------
 140    -- Storage_Size --
 141    ------------------
 142
 143    overriding function Storage_Size
 144      (Pool  : Unbounded_No_Reclaim_Pool)
 145       return  SSE.Storage_Count
 146    is
 147       pragma Warnings (Off, Pool);
 148
 149    begin
 150       --  Intuitively, should return System.Memory_Size. But on Sun/Alsys,
 151       --  System.Memory_Size > System.Max_Int, which means all you can do with
 152       --  it is raise CONSTRAINT_ERROR...
 153
 154       return SSE.Storage_Count'Last;
 155    end Storage_Size;
 156
 157 end System.Pool_Global;