File : s-cmallo-zfp.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME COMPONENTS --
4 -- --
5 -- S Y S T E M . C . M A L L O C --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2011, AdaCore --
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 -- --
19 -- --
20 -- --
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 with System.Storage_Elements;
33 with Ada.Unchecked_Conversion;
34
35 package body System.C.Malloc is
36 package SSE renames System.Storage_Elements;
37 use SSE;
38
39 Heap_Start : Character;
40 for Heap_Start'Alignment use Standard'Maximum_Alignment;
41 pragma Import (C, Heap_Start, "__heap_start");
42 -- The address of the variable is the start of the heap
43
44 Heap_End : Character;
45 pragma Import (C, Heap_End, "__heap_end");
46 -- The address of the variable is the end of the heap
47
48 function Get_Cell_Data (Cell : Cell_Acc) return Address;
49
50 procedure Add_Free_Cell (Cell : Free_Cell_Acc);
51 -- Add a cell to the free chain
52
53 procedure Remove_Free_Cell (Cell : Free_Cell_Acc);
54 -- Remove free cell from free chain
55
56 function To_Cell_Acc is new Ada.Unchecked_Conversion
57 (Address, Cell_Acc);
58 function To_Cell_Acc is new Ada.Unchecked_Conversion
59 (Free_Cell_Acc, Cell_Acc);
60 function To_Address is new Ada.Unchecked_Conversion
61 (Cell_Acc, Address);
62 function To_Free_Cell_Acc is new Ada.Unchecked_Conversion
63 (Cell_Acc, Free_Cell_Acc);
64 function To_Free_Cell_Acc is new Ada.Unchecked_Conversion
65 (Address, Free_Cell_Acc);
66
67 Cell_Size : constant SSE.Storage_Offset :=
68 Cell_Type'Size / Storage_Unit;
69
70 Free_Cell_Size : constant SSE.Storage_Offset :=
71 Free_Cell_Type'Size / Storage_Unit;
72
73 -------------------
74 -- Add_Free_Cell --
75 -------------------
76
77 procedure Add_Free_Cell (Cell : Free_Cell_Acc) is
78 Next : Free_Cell_Acc;
79 Cur : Free_Cell_Acc;
80
81 begin
82 -- Follow the chain until NEXT is larger then CELL
83
84 Next := Free_List;
85 Cur := null;
86 while Next /= null loop
87 exit when Next.Cell.Size >= Cell.Cell.Size;
88 Cur := Next;
89 Next := Next.Next_Free;
90 end loop;
91
92 -- Insert
93
94 Cell.Prev_Free := Cur;
95
96 if Cur = null then
97 Cell.Next_Free := Free_List;
98
99 if Free_List /= null then
100 Free_List.Prev_Free := Cell;
101 end if;
102
103 Free_List := Cell;
104
105 else
106 Cell.Next_Free := Next;
107
108 if Next /= null then
109 Next.Prev_Free := Cell;
110 end if;
111
112 Cur.Next_Free := Cell;
113 end if;
114 end Add_Free_Cell;
115
116 -----------
117 -- Alloc --
118 -----------
119
120 function Alloc (Size : size_t) return Address is
121 Rounded_Size : size_t;
122
123 begin
124 -- Return null address for zero length request
125
126 if Size = 0 then
127 return Null_Address;
128 end if;
129
130 -- Round size up
131
132 Rounded_Size := (Size + Standard'Maximum_Alignment);
133 Rounded_Size :=
134 Rounded_Size - Rounded_Size rem Standard'Maximum_Alignment;
135
136 -- Find a free cell
137
138 declare
139 Res : Free_Cell_Acc;
140 Next_Cell : Free_Cell_Acc;
141 New_Next_Cell : Free_Cell_Acc;
142
143 begin
144 Res := Free_List;
145
146 while Res /= null loop
147
148 -- The last cell is not a free cell
149
150 pragma Assert (To_Cell_Acc (Res) /= Last_Cell);
151
152 if Res.Cell.Size >= Rounded_Size then
153
154 -- Remove it from the list
155
156 Remove_Free_Cell (Res);
157
158 -- Can we split it?
159
160 if Res.Cell.Size - Rounded_Size >= size_t (Free_Cell_Size) then
161 Next_Cell :=
162 To_Free_Cell_Acc (Get_Next_Cell (To_Cell_Acc (Res)));
163
164 -- Create the new cell
165
166 New_Next_Cell :=
167 To_Free_Cell_Acc
168 (Get_Cell_Data (To_Cell_Acc (Res)) +
169 Storage_Offset (Rounded_Size));
170
171 New_Next_Cell.Cell :=
172 (Size => Res.Cell.Size - Rounded_Size - size_t (Cell_Size),
173 Prev => To_Cell_Acc (Res),
174 Free => True);
175
176 Next_Cell.Cell.Prev := To_Cell_Acc (New_Next_Cell);
177
178 -- Resize the returned cell
179
180 Res.Cell.Size := Rounded_Size;
181
182 -- Add the new cell to the free list
183
184 Add_Free_Cell (New_Next_Cell);
185 end if;
186
187 Res.Cell.Free := False;
188 return Get_Cell_Data (To_Cell_Acc (Res));
189 end if;
190
191 Res := Res.Next_Free;
192 end loop;
193 end;
194
195 -- No free block so create a new block
196
197 declare
198 Res : Cell_Acc;
199
200 begin
201 if Last_Cell = null then
202
203 -- Do we need to check alignment ???
204
205 Res := Get_First_Cell;
206
207 else
208 Res := Get_Next_Cell (Last_Cell);
209 end if;
210
211 Res.all := (Prev => Last_Cell,
212 Size => Rounded_Size,
213 Free => False);
214
215 -- Check heap exhaustion, and if so return null address
216
217 if To_Address (Get_Next_Cell (Res)) > Heap_End'Address then
218 return Null_Address;
219 end if;
220
221 Last_Cell := Res;
222 return Get_Cell_Data (Res);
223 end;
224 end Alloc;
225
226 ----------
227 -- Free --
228 ----------
229
230 procedure Free (Ptr : Address) is
231 Cell : Cell_Acc;
232
233 begin
234 -- Nothing to do if null address passed
235
236 if Ptr = Null_Address then
237 return;
238 end if;
239
240 Cell := To_Cell_Acc (Ptr - Cell_Size);
241 pragma Assert (not Cell.Free);
242 Cell.Free := True;
243
244 -- If Cell is the last one, free it directly
245
246 if Cell = Last_Cell then
247 Last_Cell := Cell.Prev;
248
249 -- The one before the last may be free too
250
251 if Last_Cell /= null and then Last_Cell.Free then
252
253 -- Remove it from the free list
254
255 Remove_Free_Cell (To_Free_Cell_Acc (Last_Cell));
256 Last_Cell := Last_Cell.Prev;
257
258 -- There can be only one free block before
259
260 pragma Assert (Last_Cell = null or else not Last_Cell.Free);
261 end if;
262
263 return;
264 end if;
265
266 -- Merge with the next cell?
267
268 if Cell /= Last_Cell then
269 declare
270 Next_Cell : constant Cell_Acc := Get_Next_Cell (Cell);
271
272 begin
273 if Next_Cell.Free then
274
275 -- Remove it from the free list
276
277 Remove_Free_Cell (To_Free_Cell_Acc (Next_Cell));
278
279 -- Do the merge
280
281 if Next_Cell /= Last_Cell then
282 Get_Next_Cell (Next_Cell).Prev := Cell;
283 end if;
284
285 Cell.Size := Cell.Size + Next_Cell.Size + size_t (Cell_Size);
286 end if;
287 end;
288 end if;
289
290 -- Merge with prev cell?
291
292 if Cell.Prev /= null and then Cell.Prev.Free then
293 declare
294 Prev_Cell : constant Cell_Acc := Cell.Prev;
295
296 begin
297 Remove_Free_Cell (To_Free_Cell_Acc (Prev_Cell));
298
299 -- Do the merge
300
301 if Cell /= Last_Cell then
302 Get_Next_Cell (Cell).Prev := Prev_Cell;
303 end if;
304
305 Prev_Cell.Size := Prev_Cell.Size + Cell.Size + size_t (Cell_Size);
306 Cell := Prev_Cell;
307 end;
308 end if;
309
310 Add_Free_Cell (To_Free_Cell_Acc (Cell));
311 end Free;
312
313 -------------------
314 -- Get_Cell_Data --
315 -------------------
316
317 function Get_Cell_Data (Cell : Cell_Acc) return Address is
318 begin
319 return Cell.all'Address + Cell_Size;
320 end Get_Cell_Data;
321
322 --------------------
323 -- Get_First_Cell --
324 --------------------
325
326 function Get_First_Cell return Cell_Acc is
327 begin
328 return To_Cell_Acc (Heap_Start'Address);
329 end Get_First_Cell;
330
331 -------------------
332 -- Get_Next_Cell --
333 -------------------
334
335 function Get_Next_Cell (Cell : Cell_Acc) return Cell_Acc is
336 begin
337 return To_Cell_Acc (Get_Cell_Data (Cell) + Storage_Offset (Cell.Size));
338 end Get_Next_Cell;
339
340 -------------
341 -- Realloc --
342 -------------
343
344 function Realloc (Ptr : Address; Size : size_t) return Address is
345 begin
346 -- Not yet implemented
347
348 raise Program_Error;
349 return Null_Address;
350 end Realloc;
351
352 ----------------------
353 -- Remove_Free_Cell --
354 ----------------------
355
356 procedure Remove_Free_Cell (Cell : Free_Cell_Acc) is
357 begin
358 if Cell.Next_Free /= null then
359 Cell.Next_Free.Prev_Free := Cell.Prev_Free;
360 end if;
361
362 if Cell.Prev_Free /= null then
363 Cell.Prev_Free.Next_Free := Cell.Next_Free;
364 else
365 Free_List := Cell.Next_Free;
366 end if;
367 end Remove_Free_Cell;
368 end System.C.Malloc;