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-2017, 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 := To_Address
  79            (To_Integer (Allocated) + Integer_Address (Alignment)
  80               - (To_Integer (Allocated) mod Integer_Address (Alignment)));
  81
  82          --  Save the block address
  83
  84          declare
  85             Saved_Address : System.Address;
  86             pragma Import (Ada, Saved_Address);
  87             for Saved_Address'Address use
  88                Aligned_Address
  89                - Storage_Offset (System.Address'Size / Storage_Unit);
  90          begin
  91             Saved_Address := Allocated;
  92          end;
  93
  94          Address := Aligned_Address;
  95
  96       else
  97          Address := Allocated;
  98       end if;
  99    end Allocate;
 100
 101    ----------------
 102    -- Deallocate --
 103    ----------------
 104
 105    overriding procedure Deallocate
 106      (Pool         : in out Unbounded_No_Reclaim_Pool;
 107       Address      : System.Address;
 108       Storage_Size : SSE.Storage_Count;
 109       Alignment    : SSE.Storage_Count)
 110    is
 111       use System.Storage_Elements;
 112       pragma Warnings (Off, Pool);
 113       pragma Warnings (Off, Storage_Size);
 114
 115    begin
 116       --  Case where the alignment of the block exceeds the guaranteed
 117       --  alignment required by the system storage allocator, meaning that
 118       --  this was specially wrapped at allocation time.
 119
 120       if Alignment > Standard'System_Allocator_Alignment then
 121
 122          --  Retrieve the block address
 123
 124          declare
 125             Saved_Address : System.Address;
 126             pragma Import (Ada, Saved_Address);
 127             for Saved_Address'Address use
 128               Address - Storage_Offset (System.Address'Size / Storage_Unit);
 129          begin
 130             Memory.Free (Saved_Address);
 131          end;
 132
 133       else
 134          Memory.Free (Address);
 135       end if;
 136    end Deallocate;
 137
 138    ------------------
 139    -- Storage_Size --
 140    ------------------
 141
 142    overriding function Storage_Size
 143      (Pool  : Unbounded_No_Reclaim_Pool)
 144       return  SSE.Storage_Count
 145    is
 146       pragma Warnings (Off, Pool);
 147
 148    begin
 149       --  Intuitively, should return System.Memory_Size. But on Sun/Alsys,
 150       --  System.Memory_Size > System.Max_Int, which means all you can do with
 151       --  it is raise CONSTRAINT_ERROR...
 152
 153       return SSE.Storage_Count'Last;
 154    end Storage_Size;
 155
 156 end System.Pool_Global;