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