-- GHDL Run Time (GRT) - secondary stack.
-- Copyright (C) 2002 - 2014 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.
--
-- As a special exception, if other files instantiate generics from this
-- unit, or you link this unit with other files to produce an executable,
-- this unit does not by itself cause the resulting executable to be
-- covered by the GNU General Public License. This exception does not
-- however invalidate any other reasons why the executable file might be
-- covered by the GNU Public License.
with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
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;
-- Minimal chunk size. Avoid to allocate too many small chunks.
Min_Chunk_Size : constant Mark_Id := 8 * 1024;
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;
-- Index of the first free byte.
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 : constant Stack2_Acc := To_Acc (S);
begin
return S2.Top;
end Mark;
procedure Release (S : Stack2_Ptr; Mark : Mark_Id)
is
S2 : constant Stack2_Acc := To_Acc (S);
begin
S2.Top := Mark;
end Release;
function Allocate (S : Stack2_Ptr; Size : Ghdl_Index_Type)
return System.Address
is
pragma Suppress (All_Checks);
S2 : constant Stack2_Acc := To_Acc (S);
Chunk : Chunk_Acc;
N_Chunk : Chunk_Acc;
L_Chunk : Chunk_Acc;
Max_Align : constant Mark_Id := Mark_Id (Standard'Maximum_Alignment);
Aligned_Size : constant Mark_Id :=
((Mark_Id (Size) + Max_Align - 1) / Max_Align) * Max_Align;
Res : System.Address;
begin
-- Find the chunk to which S2.TOP belong.
-- FIXME: save an hint to that value ?
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 Aligned_Size <= Chunk.Last - S2.Top + 1 then
Res := Chunk.Mem (S2.Top)'Address;
S2.Top := S2.Top + Aligned_Size;
return Res;
end if;
-- If there is not enough place in it: try the next one. If not
-- enough room, free it and all the following chunks.
L_Chunk := Chunk;
Chunk := Chunk.Next;
if Chunk /= null then
if Aligned_Size <= Chunk.Last - Chunk.First + 1 then
Res := Chunk.Mem (Chunk.First)'Address;
S2.Top := Chunk.First + Aligned_Size;
return Res;
else
-- Free Chunk and all the following ones. Do not forget to
-- update Last_Chunk.
S2.Last_Chunk := L_Chunk;
loop
N_Chunk := Chunk.Next;
Free (Chunk);
Chunk := N_Chunk;
exit when Chunk = null;
end loop;
end if;
end if;
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 + Mark_Id'Max (Aligned_Size, Min_Chunk_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 => Min_Chunk_Size);
Chunk.Next := null;
Res := new Stack2_Type'(First_Chunk => Chunk,
Last_Chunk => Chunk,
Top => 1);
return To_Addr (Res);
end Create;
-- 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;