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-2018, 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 is the default implementation of this package 33 34-- This implementation assumes that the underlying malloc/free/realloc 35-- implementation is thread safe, and thus, no additional lock is required. 36-- Note that we still need to defer abort because on most systems, an 37-- asynchronous signal (as used for implementing asynchronous abort of 38-- task) cannot safely be handled while malloc is executing. 39 40-- If you are not using Ada constructs containing the "abort" keyword, then 41-- you can remove the calls to Abort_Defer.all and Abort_Undefer.all from 42-- this unit. 43 44pragma Compiler_Unit_Warning; 45 46with System.CRTL; 47with System.Parameters; 48with System.Soft_Links; 49 50package body System.Memory is 51 52 use System.Soft_Links; 53 54 function c_malloc (Size : System.CRTL.size_t) return System.Address 55 renames System.CRTL.malloc; 56 57 procedure c_free (Ptr : System.Address) 58 renames System.CRTL.free; 59 60 function c_realloc 61 (Ptr : System.Address; Size : System.CRTL.size_t) return System.Address 62 renames System.CRTL.realloc; 63 64 ----------- 65 -- Alloc -- 66 ----------- 67 68 function Alloc (Size : size_t) return System.Address is 69 Result : System.Address; 70 begin 71 -- A previous version moved the check for size_t'Last below, into the 72 -- "if Result = System.Null_Address...". So malloc(size_t'Last) should 73 -- return Null_Address, and then we can check for that special value. 74 -- However, that doesn't work on VxWorks, because malloc(size_t'Last) 75 -- prints an unwanted warning message before returning Null_Address. 76 -- Note that the branch is correctly predicted on modern hardware, so 77 -- there is negligible overhead. 78 79 if Size = size_t'Last then 80 raise Storage_Error with "object too large"; 81 end if; 82 83 if Parameters.No_Abort then 84 Result := c_malloc (System.CRTL.size_t (Size)); 85 else 86 Abort_Defer.all; 87 Result := c_malloc (System.CRTL.size_t (Size)); 88 Abort_Undefer.all; 89 end if; 90 91 if Result = System.Null_Address then 92 93 -- If Size = 0, we can't allocate 0 bytes, because then two different 94 -- allocators, one of which has Size = 0, could return pointers that 95 -- compare equal, which is wrong. (Nonnull pointers compare equal if 96 -- and only if they designate the same object, and two different 97 -- allocators allocate two different objects). 98 99 -- malloc(0) is defined to allocate a non-zero-sized object (in which 100 -- case we won't get here, and all is well) or NULL, in which case we 101 -- get here. We also get here in case of error. So check for the 102 -- zero-size case, and allocate 1 byte. Otherwise, raise 103 -- Storage_Error. 104 105 -- We check for zero size here, rather than at the start, for 106 -- efficiency. 107 108 if Size = 0 then 109 return Alloc (1); 110 end if; 111 112 raise Storage_Error with "heap exhausted"; 113 end if; 114 115 return Result; 116 end Alloc; 117 118 ---------- 119 -- Free -- 120 ---------- 121 122 procedure Free (Ptr : System.Address) is 123 begin 124 if Parameters.No_Abort then 125 c_free (Ptr); 126 else 127 Abort_Defer.all; 128 c_free (Ptr); 129 Abort_Undefer.all; 130 end if; 131 end Free; 132 133 ------------- 134 -- Realloc -- 135 ------------- 136 137 function Realloc 138 (Ptr : System.Address; 139 Size : size_t) 140 return System.Address 141 is 142 Result : System.Address; 143 begin 144 if Size = size_t'Last then 145 raise Storage_Error with "object too large"; 146 end if; 147 148 if Parameters.No_Abort then 149 Result := c_realloc (Ptr, System.CRTL.size_t (Size)); 150 else 151 Abort_Defer.all; 152 Result := c_realloc (Ptr, System.CRTL.size_t (Size)); 153 Abort_Undefer.all; 154 end if; 155 156 if Result = System.Null_Address then 157 raise Storage_Error with "heap exhausted"; 158 end if; 159 160 return Result; 161 end Realloc; 162 163end System.Memory; 164