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