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-2011, 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 32with System.Storage_Pools; use System.Storage_Pools; 33with System.Memory; 34 35package 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 156end System.Pool_Global; 157