1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- S Y S T E M . M E M O R Y -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2001-2009, 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-- This version provides ways to limit the amount of used memory for systems 33-- that do not have OS support for that. 34 35-- The amount of available memory available for dynamic allocation is limited 36-- by setting the environment variable GNAT_MEMORY_LIMIT to the number of 37-- kilobytes that can be used. 38-- 39-- Windows is currently using this version. 40 41with Ada.Exceptions; 42with System.Soft_Links; 43 44package body System.Memory is 45 46 use Ada.Exceptions; 47 use System.Soft_Links; 48 49 function c_malloc (Size : size_t) return System.Address; 50 pragma Import (C, c_malloc, "malloc"); 51 52 procedure c_free (Ptr : System.Address); 53 pragma Import (C, c_free, "free"); 54 55 function c_realloc 56 (Ptr : System.Address; Size : size_t) return System.Address; 57 pragma Import (C, c_realloc, "realloc"); 58 59 function msize (Ptr : System.Address) return size_t; 60 pragma Import (C, msize, "_msize"); 61 62 function getenv (Str : String) return System.Address; 63 pragma Import (C, getenv); 64 65 function atoi (Str : System.Address) return Integer; 66 pragma Import (C, atoi); 67 68 Available_Memory : size_t := 0; 69 -- Amount of memory that is available for heap allocations. 70 -- A value of 0 means that the amount is not yet initialized. 71 72 Msize_Accuracy : constant := 4096; 73 -- Defines the amount of memory to add to requested allocation sizes, 74 -- because malloc may return a bigger block than requested. As msize 75 -- is used when by Free, it must be used on allocation as well. To 76 -- prevent underflow of available_memory we need to use a reserve. 77 78 procedure Check_Available_Memory (Size : size_t); 79 -- This routine must be called while holding the task lock. When the 80 -- memory limit is not yet initialized, it will be set to the value of 81 -- the GNAT_MEMORY_LIMIT environment variable or to unlimited if that 82 -- does not exist. If the size is larger than the amount of available 83 -- memory, the task lock will be freed and a storage_error exception 84 -- will be raised. 85 86 ----------- 87 -- Alloc -- 88 ----------- 89 90 function Alloc (Size : size_t) return System.Address is 91 Result : System.Address; 92 Actual_Size : size_t := Size; 93 94 begin 95 if Size = size_t'Last then 96 Raise_Exception (Storage_Error'Identity, "object too large"); 97 end if; 98 99 -- Change size from zero to non-zero. We still want a proper pointer 100 -- for the zero case because pointers to zero length objects have to 101 -- be distinct, but we can't just go ahead and allocate zero bytes, 102 -- since some malloc's return zero for a zero argument. 103 104 if Size = 0 then 105 Actual_Size := 1; 106 end if; 107 108 Lock_Task.all; 109 110 if Actual_Size + Msize_Accuracy >= Available_Memory then 111 Check_Available_Memory (Size + Msize_Accuracy); 112 end if; 113 114 Result := c_malloc (Actual_Size); 115 116 if Result /= System.Null_Address then 117 Available_Memory := Available_Memory - msize (Result); 118 end if; 119 120 Unlock_Task.all; 121 122 if Result = System.Null_Address then 123 Raise_Exception (Storage_Error'Identity, "heap exhausted"); 124 end if; 125 126 return Result; 127 end Alloc; 128 129 ---------------------------- 130 -- Check_Available_Memory -- 131 ---------------------------- 132 133 procedure Check_Available_Memory (Size : size_t) is 134 Gnat_Memory_Limit : System.Address; 135 136 begin 137 if Available_Memory = 0 then 138 139 -- The amount of available memory hasn't been initialized yet 140 141 Gnat_Memory_Limit := getenv ("GNAT_MEMORY_LIMIT" & ASCII.NUL); 142 143 if Gnat_Memory_Limit /= System.Null_Address then 144 Available_Memory := 145 size_t (atoi (Gnat_Memory_Limit)) * 1024 + Msize_Accuracy; 146 else 147 Available_Memory := size_t'Last; 148 end if; 149 end if; 150 151 if Size >= Available_Memory then 152 153 -- There is a memory overflow 154 155 Unlock_Task.all; 156 Raise_Exception 157 (Storage_Error'Identity, "heap memory limit exceeded"); 158 end if; 159 end Check_Available_Memory; 160 161 ---------- 162 -- Free -- 163 ---------- 164 165 procedure Free (Ptr : System.Address) is 166 begin 167 Lock_Task.all; 168 169 if Ptr /= System.Null_Address then 170 Available_Memory := Available_Memory + msize (Ptr); 171 end if; 172 173 c_free (Ptr); 174 175 Unlock_Task.all; 176 end Free; 177 178 ------------- 179 -- Realloc -- 180 ------------- 181 182 function Realloc 183 (Ptr : System.Address; 184 Size : size_t) 185 return System.Address 186 is 187 Result : System.Address; 188 Actual_Size : constant size_t := Size; 189 Old_Size : size_t; 190 191 begin 192 if Size = size_t'Last then 193 Raise_Exception (Storage_Error'Identity, "object too large"); 194 end if; 195 196 Lock_Task.all; 197 198 Old_Size := msize (Ptr); 199 200 -- Conservative check - no need to try to be precise here 201 202 if Size + Msize_Accuracy >= Available_Memory then 203 Check_Available_Memory (Size + Msize_Accuracy); 204 end if; 205 206 Result := c_realloc (Ptr, Actual_Size); 207 208 if Result /= System.Null_Address then 209 Available_Memory := Available_Memory + Old_Size - msize (Result); 210 end if; 211 212 Unlock_Task.all; 213 214 if Result = System.Null_Address then 215 Raise_Exception (Storage_Error'Identity, "heap exhausted"); 216 end if; 217 218 return Result; 219 end Realloc; 220 221end System.Memory; 222