aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.3.1/gcc/ada/s-memory-mingw.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.3.1/gcc/ada/s-memory-mingw.adb')
-rw-r--r--gcc-4.3.1/gcc/ada/s-memory-mingw.adb223
1 files changed, 223 insertions, 0 deletions
diff --git a/gcc-4.3.1/gcc/ada/s-memory-mingw.adb b/gcc-4.3.1/gcc/ada/s-memory-mingw.adb
new file mode 100644
index 000000000..da01b9b80
--- /dev/null
+++ b/gcc-4.3.1/gcc/ada/s-memory-mingw.adb
@@ -0,0 +1,223 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . M E M O R Y --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2001-2003 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This version provides ways to limit the amount of used memory for systems
+-- that do not have OS support for that.
+
+-- The amount of available memory available for dynamic allocation is limited
+-- by setting the environment variable GNAT_MEMORY_LIMIT to the number of
+-- kilobytes that can be used.
+--
+-- Windows is currently using this version.
+
+with Ada.Exceptions;
+with System.Soft_Links;
+
+package body System.Memory is
+
+ use Ada.Exceptions;
+ use System.Soft_Links;
+
+ function c_malloc (Size : size_t) return System.Address;
+ pragma Import (C, c_malloc, "malloc");
+
+ procedure c_free (Ptr : System.Address);
+ pragma Import (C, c_free, "free");
+
+ function c_realloc
+ (Ptr : System.Address; Size : size_t) return System.Address;
+ pragma Import (C, c_realloc, "realloc");
+
+ function msize (Ptr : System.Address) return size_t;
+ pragma Import (C, msize, "_msize");
+
+ function getenv (Str : String) return System.Address;
+ pragma Import (C, getenv);
+
+ function atoi (Str : System.Address) return Integer;
+ pragma Import (C, atoi);
+
+ Available_Memory : size_t := 0;
+ -- Amount of memory that is available for heap allocations.
+ -- A value of 0 means that the amount is not yet initialized.
+
+ Msize_Accuracy : constant := 4096;
+ -- Defines the amount of memory to add to requested allocation sizes,
+ -- because malloc may return a bigger block than requested. As msize
+ -- is used when by Free, it must be used on allocation as well. To
+ -- prevent underflow of available_memory we need to use a reserve.
+
+ procedure Check_Available_Memory (Size : size_t);
+ -- This routine must be called while holding the task lock. When the
+ -- memory limit is not yet initialized, it will be set to the value of
+ -- the GNAT_MEMORY_LIMIT environment variable or to unlimited if that
+ -- does not exist. If the size is larger than the amount of available
+ -- memory, the task lock will be freed and a storage_error exception
+ -- will be raised.
+
+ -----------
+ -- Alloc --
+ -----------
+
+ function Alloc (Size : size_t) return System.Address is
+ Result : System.Address;
+ Actual_Size : size_t := Size;
+
+ begin
+ if Size = size_t'Last then
+ Raise_Exception (Storage_Error'Identity, "object too large");
+ end if;
+
+ -- Change size from zero to non-zero. We still want a proper pointer
+ -- for the zero case because pointers to zero length objects have to
+ -- be distinct, but we can't just go ahead and allocate zero bytes,
+ -- since some malloc's return zero for a zero argument.
+
+ if Size = 0 then
+ Actual_Size := 1;
+ end if;
+
+ Lock_Task.all;
+
+ if Actual_Size + Msize_Accuracy >= Available_Memory then
+ Check_Available_Memory (Size + Msize_Accuracy);
+ end if;
+
+ Result := c_malloc (Actual_Size);
+
+ if Result /= System.Null_Address then
+ Available_Memory := Available_Memory - msize (Result);
+ end if;
+
+ Unlock_Task.all;
+
+ if Result = System.Null_Address then
+ Raise_Exception (Storage_Error'Identity, "heap exhausted");
+ end if;
+
+ return Result;
+ end Alloc;
+
+ ----------------------------
+ -- Check_Available_Memory --
+ ----------------------------
+
+ procedure Check_Available_Memory (Size : size_t) is
+ Gnat_Memory_Limit : System.Address;
+
+ begin
+ if Available_Memory = 0 then
+
+ -- The amount of available memory hasn't been initialized yet
+
+ Gnat_Memory_Limit := getenv ("GNAT_MEMORY_LIMIT" & ASCII.NUL);
+
+ if Gnat_Memory_Limit /= System.Null_Address then
+ Available_Memory :=
+ size_t (atoi (Gnat_Memory_Limit)) * 1024 + Msize_Accuracy;
+ else
+ Available_Memory := size_t'Last;
+ end if;
+ end if;
+
+ if Size >= Available_Memory then
+
+ -- There is a memory overflow
+
+ Unlock_Task.all;
+ Raise_Exception
+ (Storage_Error'Identity, "heap memory limit exceeded");
+ end if;
+ end Check_Available_Memory;
+
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free (Ptr : System.Address) is
+ begin
+ Lock_Task.all;
+
+ if Ptr /= System.Null_Address then
+ Available_Memory := Available_Memory + msize (Ptr);
+ end if;
+
+ c_free (Ptr);
+
+ Unlock_Task.all;
+ end Free;
+
+ -------------
+ -- Realloc --
+ -------------
+
+ function Realloc
+ (Ptr : System.Address;
+ Size : size_t)
+ return System.Address
+ is
+ Result : System.Address;
+ Actual_Size : constant size_t := Size;
+ Old_Size : size_t;
+
+ begin
+ if Size = size_t'Last then
+ Raise_Exception (Storage_Error'Identity, "object too large");
+ end if;
+
+ Lock_Task.all;
+
+ Old_Size := msize (Ptr);
+
+ -- Conservative check - no need to try to be precise here
+
+ if Size + Msize_Accuracy >= Available_Memory then
+ Check_Available_Memory (Size + Msize_Accuracy);
+ end if;
+
+ Result := c_realloc (Ptr, Actual_Size);
+
+ if Result /= System.Null_Address then
+ Available_Memory := Available_Memory + Old_Size - msize (Result);
+ end if;
+
+ Unlock_Task.all;
+
+ if Result = System.Null_Address then
+ Raise_Exception (Storage_Error'Identity, "heap exhausted");
+ end if;
+
+ return Result;
+ end Realloc;
+
+end System.Memory;