1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- S Y S T E M . M E M O R Y --
10 -- Copyright (C) 2001 Free Software Foundation, Inc. --
12 -- This specification is derived from the Ada Reference Manual for use with --
13 -- GNAT. The copyright notice above, and the license provisions that follow --
14 -- apply solely to the contents of the part following the private keyword. --
16 -- GNAT is free software; you can redistribute it and/or modify it under --
17 -- terms of the GNU General Public License as published by the Free Soft- --
18 -- ware Foundation; either version 2, or (at your option) any later ver- --
19 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
20 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
21 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
22 -- for more details. You should have received a copy of the GNU General --
23 -- Public License distributed with GNAT; see file COPYING. If not, write --
24 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
25 -- MA 02111-1307, USA. --
27 -- As a special exception, if other files instantiate generics from this --
28 -- unit, or you link this unit with other files to produce an executable, --
29 -- this unit does not by itself cause the resulting executable to be --
30 -- covered by the GNU General Public License. This exception does not --
31 -- however invalidate any other reasons why the executable file might be --
32 -- covered by the GNU Public License. --
34 -- GNAT was originally developed by the GNAT team at New York University. --
35 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
37 ------------------------------------------------------------------------------
39 -- This version provides ways to limit the amount of used memory for systems
40 -- that do not have OS support for that.
42 -- The amount of available memory available for dynamic allocation is limited
43 -- by setting the environment variable GNAT_MEMORY_LIMIT to the number of
44 -- kilobytes that can be used.
46 -- Windows is currently using this version.
49 with System
.Soft_Links
;
51 package body System
.Memory
is
54 use System
.Soft_Links
;
56 function c_malloc
(Size
: size_t
) return System
.Address
;
57 pragma Import
(C
, c_malloc
, "malloc");
59 procedure c_free
(Ptr
: System
.Address
);
60 pragma Import
(C
, c_free
, "free");
63 (Ptr
: System
.Address
; Size
: size_t
) return System
.Address
;
64 pragma Import
(C
, c_realloc
, "realloc");
66 function msize
(Ptr
: System
.Address
) return size_t
;
67 pragma Import
(C
, msize
, "_msize");
69 function getenv
(Str
: String) return System
.Address
;
70 pragma Import
(C
, getenv
);
72 function atoi
(Str
: System
.Address
) return Integer;
73 pragma Import
(C
, atoi
);
75 Available_Memory
: size_t
:= 0;
76 -- Amount of memory that is available for heap allocations.
77 -- A value of 0 means that the amount is not yet initialized.
79 Msize_Accuracy
: constant := 4096;
80 -- Defines the amount of memory to add to requested allocation sizes,
81 -- because malloc may return a bigger block than requested. As msize
82 -- is used when by Free, it must be used on allocation as well. To
83 -- prevent underflow of available_memory we need to use a reserve.
85 procedure Check_Available_Memory
(Size
: size_t
);
86 -- This routine must be called while holding the task lock. When the
87 -- memory limit is not yet initialized, it will be set to the value of
88 -- the GNAT_MEMORY_LIMIT environment variable or to unlimited if that
89 -- does not exist. If the size is larger than the amount of available
90 -- memory, the task lock will be freed and a storage_error exception
97 function Alloc
(Size
: size_t
) return System
.Address
is
98 Result
: System
.Address
;
99 Actual_Size
: size_t
:= Size
;
102 if Size
= size_t
'Last then
103 Raise_Exception
(Storage_Error
'Identity, "object too large");
106 -- Change size from zero to non-zero. We still want a proper pointer
107 -- for the zero case because pointers to zero length objects have to
108 -- be distinct, but we can't just go ahead and allocate zero bytes,
109 -- since some malloc's return zero for a zero argument.
117 if Actual_Size
+ Msize_Accuracy
>= Available_Memory
then
118 Check_Available_Memory
(Size
+ Msize_Accuracy
);
121 Result
:= c_malloc
(Actual_Size
);
123 if Result
/= System
.Null_Address
then
124 Available_Memory
:= Available_Memory
- msize
(Result
);
129 if Result
= System
.Null_Address
then
130 Raise_Exception
(Storage_Error
'Identity, "heap exhausted");
136 ----------------------------
137 -- Check_Available_Memory --
138 ----------------------------
140 procedure Check_Available_Memory
(Size
: size_t
) is
141 Gnat_Memory_Limit
: System
.Address
;
144 if Available_Memory
= 0 then
146 -- The amount of available memory hasn't been initialized yet
148 Gnat_Memory_Limit
:= getenv
("GNAT_MEMORY_LIMIT" & ASCII
.NUL
);
150 if Gnat_Memory_Limit
/= System
.Null_Address
then
152 size_t
(atoi
(Gnat_Memory_Limit
)) * 1024 + Msize_Accuracy
;
154 Available_Memory
:= size_t
'Last;
158 if Size
>= Available_Memory
then
160 -- There is a memory overflow
164 (Storage_Error
'Identity, "heap memory limit exceeded");
166 end Check_Available_Memory
;
172 procedure Free
(Ptr
: System
.Address
) is
176 if Ptr
/= System
.Null_Address
then
177 Available_Memory
:= Available_Memory
+ msize
(Ptr
);
190 (Ptr
: System
.Address
;
192 return System
.Address
194 Result
: System
.Address
;
195 Actual_Size
: size_t
:= Size
;
199 if Size
= size_t
'Last then
200 Raise_Exception
(Storage_Error
'Identity, "object too large");
205 Old_Size
:= msize
(Ptr
);
207 -- Conservative check - no need to try to be precise here
209 if Size
+ Msize_Accuracy
>= Available_Memory
then
210 Check_Available_Memory
(Size
+ Msize_Accuracy
);
213 Result
:= c_realloc
(Ptr
, Actual_Size
);
215 if Result
/= System
.Null_Address
then
216 Available_Memory
:= Available_Memory
+ Old_Size
- msize
(Result
);
221 if Result
= System
.Null_Address
then
222 Raise_Exception
(Storage_Error
'Identity, "heap exhausted");