1--  GHDL Run Time (GRT) - secondary stack.
2--  Copyright (C) 2002 - 2014 Tristan Gingold
3--
4--  This program is free software: you can redistribute it and/or modify
5--  it under the terms of the GNU General Public License as published by
6--  the Free Software Foundation, either version 2 of the License, or
7--  (at your option) any later version.
8--
9--  This program is distributed in the hope that it will be useful,
10--  but WITHOUT ANY WARRANTY; without even the implied warranty of
11--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12--  GNU General Public License for more details.
13--
14--  You should have received a copy of the GNU General Public License
15--  along with this program.  If not, see <gnu.org/licenses>.
16--
17--  As a special exception, if other files instantiate generics from this
18--  unit, or you link this unit with other files to produce an executable,
19--  this unit does not by itself cause the resulting executable to be
20--  covered by the GNU General Public License. This exception does not
21--  however invalidate any other reasons why the executable file might be
22--  covered by the GNU Public License.
23with Ada.Unchecked_Conversion;
24with Ada.Unchecked_Deallocation;
25with Grt.Stdio;
26with Grt.Astdio;
27
28package body Grt.Stack2 is
29   --  This should be storage_elements.storage_element, but I don't want to
30   --  use system.storage_elements package (not pure).  Unfortunatly, this is
31   --  currently a failure (storage_elements is automagically used).
32   type Memory is array (Mark_Id range <>) of Character;
33
34   --  Minimal chunk size.  Avoid to allocate too many small chunks.
35   Min_Chunk_Size : constant Mark_Id := 8 * 1024;
36
37   type Chunk_Type (First, Last : Mark_Id);
38   type Chunk_Acc is access all Chunk_Type;
39   type Chunk_Type (First, Last : Mark_Id) is record
40      Next : Chunk_Acc;
41      Mem : Memory (First .. Last);
42   end record;
43
44   type Stack2_Type is record
45      First_Chunk : Chunk_Acc;
46      Last_Chunk : Chunk_Acc;
47
48      --  Index of the first free byte.
49      Top : Mark_Id;
50   end record;
51   type Stack2_Acc is access all Stack2_Type;
52
53   function To_Acc is new Ada.Unchecked_Conversion
54     (Source => Stack2_Ptr, Target => Stack2_Acc);
55   function To_Addr is new Ada.Unchecked_Conversion
56     (Source => Stack2_Acc, Target => Stack2_Ptr);
57
58   procedure Free is new Ada.Unchecked_Deallocation
59     (Object => Chunk_Type, Name => Chunk_Acc);
60
61   function Mark (S : Stack2_Ptr) return Mark_Id
62   is
63      S2 : constant Stack2_Acc := To_Acc (S);
64   begin
65      return S2.Top;
66   end Mark;
67
68   procedure Release (S : Stack2_Ptr; Mark : Mark_Id)
69   is
70      S2 : constant Stack2_Acc := To_Acc (S);
71   begin
72      S2.Top := Mark;
73   end Release;
74
75   function Allocate (S : Stack2_Ptr; Size : Ghdl_Index_Type)
76                     return System.Address
77   is
78      pragma Suppress (All_Checks);
79
80      S2 : constant Stack2_Acc := To_Acc (S);
81      Chunk : Chunk_Acc;
82      N_Chunk : Chunk_Acc;
83      L_Chunk : Chunk_Acc;
84
85      Max_Align : constant Mark_Id := Mark_Id (Standard'Maximum_Alignment);
86      Aligned_Size  : constant Mark_Id :=
87        ((Mark_Id (Size) + Max_Align - 1) / Max_Align) * Max_Align;
88
89      Res : System.Address;
90   begin
91      --  Find the chunk to which S2.TOP belong.
92      --  FIXME: save an hint to that value ?
93      Chunk := S2.First_Chunk;
94      loop
95         exit when S2.Top >= Chunk.First and S2.Top <= Chunk.Last;
96         Chunk := Chunk.Next;
97         exit when Chunk = null;
98      end loop;
99
100      if Chunk /= null then
101         --  If there is enough place in it, allocate from the chunk.
102         if Aligned_Size <= Chunk.Last - S2.Top + 1 then
103            Res := Chunk.Mem (S2.Top)'Address;
104            S2.Top := S2.Top + Aligned_Size;
105            return Res;
106         end if;
107
108         --  If there is not enough place in it: try the next one.  If not
109         --   enough room, free it and all the following chunks.
110         L_Chunk := Chunk;
111         Chunk := Chunk.Next;
112         if Chunk /= null then
113            if Aligned_Size <= Chunk.Last - Chunk.First + 1 then
114               Res := Chunk.Mem (Chunk.First)'Address;
115               S2.Top := Chunk.First + Aligned_Size;
116               return Res;
117            else
118               --  Free Chunk and all the following ones.  Do not forget to
119               --  update Last_Chunk.
120               S2.Last_Chunk := L_Chunk;
121               loop
122                  N_Chunk := Chunk.Next;
123                  Free (Chunk);
124                  Chunk := N_Chunk;
125                  exit when Chunk = null;
126               end loop;
127            end if;
128         end if;
129      end if;
130
131      --    If not such chunk, allocate a chunk
132      S2.Top := S2.Last_Chunk.Last + 1;
133      Chunk := new Chunk_Type
134        (First => S2.Top,
135         Last => S2.Top + Mark_Id'Max (Aligned_Size, Min_Chunk_Size) - 1);
136      Chunk.Next := null;
137      S2.Last_Chunk.Next := Chunk;
138      S2.Last_Chunk := Chunk;
139      S2.Top := Chunk.Last + 1;
140      return Chunk.Mem (Chunk.First)'Address;
141   end Allocate;
142
143   function Create return Stack2_Ptr
144   is
145      Res : Stack2_Acc;
146      Chunk : Chunk_Acc;
147   begin
148      Chunk := new Chunk_Type (First => 1, Last => Min_Chunk_Size);
149      Chunk.Next := null;
150      Res := new Stack2_Type'(First_Chunk => Chunk,
151                              Last_Chunk => Chunk,
152                              Top => 1);
153      return To_Addr (Res);
154   end Create;
155
156   function Is_Empty (S : Stack2_Ptr) return Boolean
157   is
158      S2 : constant Stack2_Acc := To_Acc (S);
159   begin
160      if S2 = null then
161         return True;
162      end if;
163      return S2.Top = 1;
164   end Is_Empty;
165
166   procedure Dump_Stack2 (S : Stack2_Ptr)
167   is
168      use Grt.Astdio;
169      use Grt.Stdio;
170      use System;
171      function To_Address is new Ada.Unchecked_Conversion
172        (Source => Chunk_Acc, Target => Address);
173      function To_Address is new Ada.Unchecked_Conversion
174        (Source => Mark_Id, Target => Address);
175      S2 : Stack2_Acc;
176      Chunk : Chunk_Acc;
177   begin
178      S2 := To_Acc (S);
179      Put ("Stack 2 at ");
180      Put (stdout, Address (S));
181      New_Line;
182      if S2 = null then
183         return;
184      end if;
185      Put ("First Chunk at ");
186      Put (stdout, To_Address (S2.First_Chunk));
187      Put (", last chunk at ");
188      Put (stdout, To_Address (S2.Last_Chunk));
189      Put (", top at ");
190      Put (stdout, To_Address (S2.Top));
191      New_Line;
192      Chunk := S2.First_Chunk;
193      while Chunk /= null loop
194         Put ("Chunk ");
195         Put (stdout, To_Address (Chunk));
196         Put (": first: ");
197         Put (stdout, To_Address (Chunk.First));
198         Put (", last: ");
199         Put (stdout, To_Address (Chunk.Last));
200         Put (", len: ");
201         Put (stdout, To_Address (Chunk.Last - Chunk.First + 1));
202         Put (", next = ");
203         Put (stdout, To_Address (Chunk.Next));
204         New_Line;
205         Chunk := Chunk.Next;
206      end loop;
207   end Dump_Stack2;
208end Grt.Stack2;
209