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