diff options
Diffstat (limited to 'translate/grt/grt-stack2.adb')
| -rw-r--r-- | translate/grt/grt-stack2.adb | 198 |
1 files changed, 198 insertions, 0 deletions
diff --git a/translate/grt/grt-stack2.adb b/translate/grt/grt-stack2.adb new file mode 100644 index 0000000..17bb2c9 --- /dev/null +++ b/translate/grt/grt-stack2.adb @@ -0,0 +1,198 @@ +-- GHDL Run Time (GRT) - secondary stack. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; +with Grt.Errors; use Grt.Errors; +with Grt.Stdio; +with Grt.Astdio; + +package body Grt.Stack2 is + -- This should be storage_elements.storage_element, but I don't want to + -- use system.storage_elements package (not pure). Unfortunatly, this is + -- currently a failure (storage_elements is automagically used). + type Memory is array (Mark_Id range <>) of Character; + + type Chunk_Type (First, Last : Mark_Id); + type Chunk_Acc is access all Chunk_Type; + type Chunk_Type (First, Last : Mark_Id) is record + Next : Chunk_Acc; + Mem : Memory (First .. Last); + end record; + + type Stack2_Type is record + First_Chunk : Chunk_Acc; + Last_Chunk : Chunk_Acc; + Top : Mark_Id; + end record; + type Stack2_Acc is access all Stack2_Type; + + function To_Acc is new Ada.Unchecked_Conversion + (Source => Stack2_Ptr, Target => Stack2_Acc); + function To_Addr is new Ada.Unchecked_Conversion + (Source => Stack2_Acc, Target => Stack2_Ptr); + + procedure Free is new Ada.Unchecked_Deallocation + (Object => Chunk_Type, Name => Chunk_Acc); + + function Mark (S : Stack2_Ptr) return Mark_Id + is + S2 : Stack2_Acc; + begin + S2 := To_Acc (S); + return S2.Top; + end Mark; + + procedure Release (S : Stack2_Ptr; Mark : Mark_Id) + is + S2 : Stack2_Acc; + begin + S2 := To_Acc (S); + S2.Top := Mark; + end Release; + + function Allocate (S : Stack2_Ptr; Size : Ghdl_Index_Type) + return System.Address + is + pragma Suppress (All_Checks); + + S2 : Stack2_Acc; + Chunk : Chunk_Acc; + N_Chunk : Chunk_Acc; + + Max_Align : constant Mark_Id := Mark_Id (Standard'Maximum_Alignment); + Max_Size : constant Mark_Id := + ((Mark_Id (Size) + Max_Align - 1) / Max_Align) * Max_Align; + + Res : System.Address; + begin + S2 := To_Acc (S); + + -- Find the chunk to which S2.TOP belong. + Chunk := S2.First_Chunk; + loop + exit when S2.Top >= Chunk.First and S2.Top <= Chunk.Last; + Chunk := Chunk.Next; + exit when Chunk = null; + end loop; + + if Chunk /= null then + -- If there is enough place in it, allocate from the chunk. + if S2.Top + Max_Size <= Chunk.Last then + Res := Chunk.Mem (S2.Top)'Address; + S2.Top := S2.Top + Max_Size; + return Res; + end if; + + -- If there is not enough place in it: + -- find a chunk which has enough room, deallocate skipped chunk. + loop + N_Chunk := Chunk.Next; + exit when N_Chunk = null; + if N_Chunk.Last - N_Chunk.First + 1 < Max_Size then + -- Not enough place in this chunk. + Chunk.Next := N_Chunk.Next; + Free (N_Chunk); + if Chunk.Next = null then + S2.Last_Chunk := Chunk; + exit; + end if; + else + Res := N_Chunk.Mem (N_Chunk.First)'Address; + S2.Top := N_Chunk.First + Max_Size; + return Res; + end if; + end loop; + end if; + + -- If not such chunk, allocate a chunk + S2.Top := S2.Last_Chunk.Last + 1; + Chunk := new Chunk_Type (First => S2.Top, + Last => S2.Top + Max_Size - 1); + Chunk.Next := null; + S2.Last_Chunk.Next := Chunk; + S2.Last_Chunk := Chunk; + S2.Top := Chunk.Last + 1; + return Chunk.Mem (Chunk.First)'Address; + end Allocate; + + function Create return Stack2_Ptr is + Res : Stack2_Acc; + Chunk : Chunk_Acc; + begin + Chunk := new Chunk_Type (First => 1, Last => 8 * 1024); + Chunk.Next := null; + Res := new Stack2_Type'(First_Chunk => Chunk, + Last_Chunk => Chunk, + Top => 1); + return To_Addr (Res); + end Create; + + procedure Check_Empty (S : Stack2_Ptr) + is + S2 : Stack2_Acc; + begin + S2 := To_Acc (S); + if S2 /= null and then S2.Top /= S2.First_Chunk.First then + Internal_Error ("stack2.check_empty: stack is not empty"); + end if; + end Check_Empty; + + -- May be used to debug. + procedure Dump_Stack2 (S : Stack2_Ptr); + pragma Unreferenced (Dump_Stack2); + + procedure Dump_Stack2 (S : Stack2_Ptr) + is + use Grt.Astdio; + use Grt.Stdio; + use System; + function To_Address is new Ada.Unchecked_Conversion + (Source => Chunk_Acc, Target => Address); + function To_Address is new Ada.Unchecked_Conversion + (Source => Mark_Id, Target => Address); + S2 : Stack2_Acc; + Chunk : Chunk_Acc; + begin + S2 := To_Acc (S); + Put ("Stack 2 at "); + Put (stdout, Address (S)); + New_Line; + Put ("First Chunk at "); + Put (stdout, To_Address (S2.First_Chunk)); + Put (", last chunk at "); + Put (stdout, To_Address (S2.Last_Chunk)); + Put (", top at "); + Put (stdout, To_Address (S2.Top)); + New_Line; + Chunk := S2.First_Chunk; + while Chunk /= null loop + Put ("Chunk "); + Put (stdout, To_Address (Chunk)); + Put (": first: "); + Put (stdout, To_Address (Chunk.First)); + Put (", last: "); + Put (stdout, To_Address (Chunk.Last)); + Put (", len: "); + Put (stdout, To_Address (Chunk.Last - Chunk.First + 1)); + Put (", next = "); + Put (stdout, To_Address (Chunk.Next)); + New_Line; + Chunk := Chunk.Next; + end loop; + end Dump_Stack2; +end Grt.Stack2; |