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