1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S Y S T E M . P O O L _ L O C A L -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2011, 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 32with System.Memory; 33 34with Ada.Unchecked_Conversion; 35 36package body System.Pool_Local is 37 38 package SSE renames System.Storage_Elements; 39 use type SSE.Storage_Offset; 40 41 Pointer_Size : constant SSE.Storage_Offset := Address'Size / Storage_Unit; 42 Pointers_Size : constant SSE.Storage_Offset := 2 * Pointer_Size; 43 44 type Acc_Address is access all Address; 45 function To_Acc_Address is 46 new Ada.Unchecked_Conversion (Address, Acc_Address); 47 48 ----------------------- 49 -- Local Subprograms -- 50 ----------------------- 51 52 function Next (A : Address) return Acc_Address; 53 pragma Inline (Next); 54 -- Given an address of a block, return an access to the next block 55 56 function Prev (A : Address) return Acc_Address; 57 pragma Inline (Prev); 58 -- Given an address of a block, return an access to the previous block 59 60 -------------- 61 -- Allocate -- 62 -------------- 63 64 procedure Allocate 65 (Pool : in out Unbounded_Reclaim_Pool; 66 Address : out System.Address; 67 Storage_Size : SSE.Storage_Count; 68 Alignment : SSE.Storage_Count) 69 is 70 pragma Warnings (Off, Alignment); 71 72 Allocated : constant System.Address := 73 Memory.Alloc 74 (Memory.size_t (Storage_Size + Pointers_Size)); 75 76 begin 77 -- The call to Alloc returns an address whose alignment is compatible 78 -- with the worst case alignment requirement for the machine; thus the 79 -- Alignment argument can be safely ignored. 80 81 if Allocated = Null_Address then 82 raise Storage_Error; 83 else 84 Address := Allocated + Pointers_Size; 85 Next (Allocated).all := Pool.First; 86 Prev (Allocated).all := Null_Address; 87 88 if Pool.First /= Null_Address then 89 Prev (Pool.First).all := Allocated; 90 end if; 91 92 Pool.First := Allocated; 93 end if; 94 end Allocate; 95 96 ---------------- 97 -- Deallocate -- 98 ---------------- 99 100 procedure Deallocate 101 (Pool : in out Unbounded_Reclaim_Pool; 102 Address : System.Address; 103 Storage_Size : SSE.Storage_Count; 104 Alignment : SSE.Storage_Count) 105 is 106 pragma Warnings (Off, Storage_Size); 107 pragma Warnings (Off, Alignment); 108 109 Allocated : constant System.Address := Address - Pointers_Size; 110 111 begin 112 if Prev (Allocated).all = Null_Address then 113 Pool.First := Next (Allocated).all; 114 115 -- Comment needed 116 117 if Pool.First /= Null_Address then 118 Prev (Pool.First).all := Null_Address; 119 end if; 120 else 121 Next (Prev (Allocated).all).all := Next (Allocated).all; 122 end if; 123 124 if Next (Allocated).all /= Null_Address then 125 Prev (Next (Allocated).all).all := Prev (Allocated).all; 126 end if; 127 128 Memory.Free (Allocated); 129 end Deallocate; 130 131 -------------- 132 -- Finalize -- 133 -------------- 134 135 procedure Finalize (Pool : in out Unbounded_Reclaim_Pool) is 136 N : System.Address := Pool.First; 137 Allocated : System.Address; 138 139 begin 140 while N /= Null_Address loop 141 Allocated := N; 142 N := Next (N).all; 143 Memory.Free (Allocated); 144 end loop; 145 end Finalize; 146 147 ---------- 148 -- Next -- 149 ---------- 150 151 function Next (A : Address) return Acc_Address is 152 begin 153 return To_Acc_Address (A); 154 end Next; 155 156 ---------- 157 -- Prev -- 158 ---------- 159 160 function Prev (A : Address) return Acc_Address is 161 begin 162 return To_Acc_Address (A + Pointer_Size); 163 end Prev; 164 165end System.Pool_Local; 166