-- Synthesis context.
-- Copyright (C) 2017 Tristan Gingold
--
-- This file is part of GHDL.
--
-- This program 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 of the License, or
-- (at your option) any later version.
--
-- This program 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 this program. If not, see <gnu.org/licenses>.
with Ada.Unchecked_Deallocation;
with Tables;
with Vhdl.Errors; use Vhdl.Errors;
with Vhdl.Utils;
package body Elab.Vhdl_Context is
Sig_Nbr : Signal_Index_Type := No_Signal_Index;
function Get_Nbr_Signal return Signal_Index_Type is
begin
return Sig_Nbr;
end Get_Nbr_Signal;
package Inst_Tables is new Tables
(Table_Component_Type => Synth_Instance_Acc,
Table_Index_Type => Instance_Id_Type,
Table_Low_Bound => First_Instance_Id,
Table_Initial => 16);
function Get_Instance_Id (Inst : Synth_Instance_Acc)
return Instance_Id_Type is
begin
return Inst.Id;
end Get_Instance_Id;
procedure Make_Root_Instance is
begin
-- Allow multiple elaborations
-- pragma Assert (Root_Instance = null);
Root_Instance :=
new Synth_Instance_Type'(Max_Objs => Global_Info.Nbr_Objects,
Is_Const => False,
Is_Error => False,
Flag1 | Flag2 => False,
Id => Inst_Tables.Last + 1,
Block_Scope => Global_Info,
Up_Block => null,
Uninst_Scope => null,
Stmt => Null_Node,
Source_Scope => Null_Node,
Caller => null,
Config => Null_Node,
Foreign => 0,
Extra_Units => null,
Extra_Link => null,
Elab_Objects => 0,
Objects => (others => (Kind => Obj_None)));
Inst_Tables.Append (Root_Instance);
end Make_Root_Instance;
procedure Free_Base_Instance is
begin
-- TODO: really free.
null;
end Free_Base_Instance;
function Make_Elab_Instance (Parent : Synth_Instance_Acc;
Stmt : Node;
Blk : Node;
Config : Node)
return Synth_Instance_Acc
is
Info : constant Sim_Info_Acc := Get_Info (Blk);
Scope : constant Sim_Info_Acc := Get_Info_Scope (Blk);
Nbr_Objs : Object_Slot_Type;
Res : Synth_Instance_Acc;
begin
if Scope = null then
-- Foreign modules are not annotated.
pragma Assert (Get_Kind (Blk) = Iir_Kind_Foreign_Module);
Nbr_Objs := 0;
else
Nbr_Objs := Info.Nbr_Objects;
end if;
Res := new Synth_Instance_Type'(Max_Objs => Nbr_Objs,
Is_Const => False,
Is_Error => False,
Flag1 | Flag2 => False,
Id => Inst_Tables.Last + 1,
Block_Scope => Scope,
Up_Block => Parent,
Uninst_Scope => null,
Stmt => Stmt,
Source_Scope => Blk,
Caller => null,
Config => Config,
Foreign => 0,
Extra_Units => null,
Extra_Link => null,
Elab_Objects => 0,
Objects => (others =>
(Kind => Obj_None)));
Inst_Tables.Append (Res);
return Res;
end Make_Elab_Instance;
procedure Free_Elab_Instance (Synth_Inst : in out Synth_Instance_Acc)
is
procedure Deallocate is new Ada.Unchecked_Deallocation
(Synth_Instance_Type, Synth_Instance_Acc);
Id : constant Instance_Id_Type := Synth_Inst.Id;
begin
Deallocate (Synth_Inst);
if Id = Inst_Tables.Last then
Inst_Tables.Decrement_Last;
else
Inst_Tables.Table (Id) := null;
end if;
end Free_Elab_Instance;
function Make_Elab_Generate_Instance
(Parent : Synth_Instance_Acc; Blk : Node; Config : Node; Len : Natural)
return Synth_Instance_Acc
is
Info : constant Sim_Info_Acc := Get_Info (Blk);
Res : Synth_Instance_Acc;
begin
Res := new Synth_Instance_Type'(Max_Objs => Object_Slot_Type (Len),
Is_Const => False,
Is_Error => False,
Flag1 | Flag2 => False,
Id => Inst_Tables.Last + 1,
Block_Scope => Info,
Up_Block => Parent,
Uninst_Scope => null,
Stmt => Blk, -- TBC.
Source_Scope => Blk,
Caller => null,
Config => Config,
Foreign => 0,
Extra_Units => null,
Extra_Link => null,
Elab_Objects => 0,
Objects => (others =>
(Kind => Obj_None)));
Inst_Tables.Append (Res);
return Res;
end Make_Elab_Generate_Instance;
function Get_Generate_Sub_Instance
(Parent : Synth_Instance_Acc; Idx : Positive) return Synth_Instance_Acc is
begin
return Parent.Objects (Object_Slot_Type (Idx)).I_Inst;
end Get_Generate_Sub_Instance;
procedure Set_Generate_Sub_Instance
(Parent : Synth_Instance_Acc; Idx : Positive; Child : Synth_Instance_Acc)
is
begin
Parent.Objects (Object_Slot_Type (Idx)) := (Obj_Instance, Child);
end Set_Generate_Sub_Instance;
function Is_Error (Inst : Synth_Instance_Acc) return Boolean is
begin
return Inst.Is_Error;
end Is_Error;
procedure Set_Error (Inst : Synth_Instance_Acc) is
begin
Inst.Is_Error := True;
end Set_Error;
function Get_Source_Scope (Inst : Synth_Instance_Acc) return Node is
begin
return Inst.Source_Scope;
end Get_Source_Scope;
function Get_Statement_Scope (Inst : Synth_Instance_Acc) return Node is
begin
return Inst.Stmt;
end Get_Statement_Scope;
function Get_Instance_Parent (Inst : Synth_Instance_Acc)
return Synth_Instance_Acc is
begin
return Inst.Up_Block;
end Get_Instance_Parent;
function Get_Instance_Const (Inst : Synth_Instance_Acc) return Boolean is
begin
return Inst.Is_Const;
end Get_Instance_Const;
function Check_Set_Instance_Const (Inst : Synth_Instance_Acc)
return Boolean is
begin
for I in 1 .. Inst.Elab_Objects loop
if Inst.Objects (I).Kind /= Obj_Subtype then
return False;
end if;
end loop;
return True;
end Check_Set_Instance_Const;
procedure Set_Instance_Const (Inst : Synth_Instance_Acc; Val : Boolean) is
begin
pragma Assert (not Val or else Check_Set_Instance_Const (Inst));
Inst.Is_Const := Val;
end Set_Instance_Const;
procedure Set_Instance_Config (Inst : Synth_Instance_Acc; Config : Node) is
begin
pragma Assert (Inst.Config = Null_Node);
Inst.Config := Config;
end Set_Instance_Config;
function Get_Instance_Config (Inst : Synth_Instance_Acc) return Node is
begin
return Inst.Config;
end Get_Instance_Config;
procedure Set_Instance_Foreign (Inst : Synth_Instance_Acc; N : Int32) is
begin
pragma Assert (Inst.Foreign = 0);
Inst.Foreign := N;
end Set_Instance_Foreign;
function Get_Instance_Foreign (Inst : Synth_Instance_Acc) return Int32 is
begin
return Inst.Foreign;
end Get_Instance_Foreign;
procedure Set_Indiv_Signal_Assoc_Flag (Inst : Synth_Instance_Acc) is
begin
Inst.Flag1 := True;
end Set_Indiv_Signal_Assoc_Flag;
function Get_Indiv_Signal_Assoc_Flag (Inst : Synth_Instance_Acc)
return Boolean is
begin
return Inst.Flag1;
end Get_Indiv_Signal_Assoc_Flag;
procedure Set_Indiv_Signal_Assoc_Parent_Flag (Inst : Synth_Instance_Acc) is
begin
Inst.Flag2 := True;
end Set_Indiv_Signal_Assoc_Parent_Flag;
function Get_Indiv_Signal_Assoc_Parent_Flag (Inst : Synth_Instance_Acc)
return Boolean is
begin
return Inst.Flag2;
end Get_Indiv_Signal_Assoc_Parent_Flag;
procedure Add_Extra_Instance (Inst : Synth_Instance_Acc;
Extra : Synth_Instance_Acc) is
begin
pragma Assert (Extra.Extra_Link = null);
Extra.Extra_Link := Inst.Extra_Units;
Inst.Extra_Units := Extra;
end Add_Extra_Instance;
function Get_First_Extra_Instance (Inst : Synth_Instance_Acc)
return Synth_Instance_Acc is
begin
return Inst.Extra_Units;
end Get_First_Extra_Instance;
function Get_Next_Extra_Instance (Inst : Synth_Instance_Acc)
return Synth_Instance_Acc is
begin
return Inst.Extra_Link;
end Get_Next_Extra_Instance;
procedure Create_Object (Syn_Inst : Synth_Instance_Acc;
Slot : Object_Slot_Type;
Num : Object_Slot_Type := 1) is
begin
-- Check elaboration order.
-- Note: this is not done for package since objects from package are
-- commons (same scope), and package annotation order can be different
-- from package elaboration order (eg: body).
if Slot /= Syn_Inst.Elab_Objects + 1
or else Syn_Inst.Objects (Slot).Kind /= Obj_None
then
Error_Msg_Elab ("synth: bad elaboration order of objects");
raise Internal_Error;
end if;
Syn_Inst.Elab_Objects := Slot + Num - 1;
end Create_Object;
procedure Create_Object_Force
(Syn_Inst : Synth_Instance_Acc; Decl : Node; Vt : Valtyp)
is
Info : constant Sim_Info_Acc := Get_Info (Decl);
begin
pragma Assert
(Syn_Inst.Objects (Info.Slot).Kind = Obj_None
or else Vt = (null, null)
or else Syn_Inst.Objects (Info.Slot) = (Kind => Obj_Object,
Obj => No_Valtyp));
Syn_Inst.Objects (Info.Slot) := (Kind => Obj_Object, Obj => Vt);
end Create_Object_Force;
procedure Create_Object_Marker
(Syn_Inst : Synth_Instance_Acc; N : Node; Pool : Areapools.Areapool_Acc)
is
use Areapools;
Info : constant Sim_Info_Acc := Get_Info (N);
begin
Create_Object (Syn_Inst, Info.Slot, 1);
Syn_Inst.Objects (Info.Slot) := (Kind => Obj_Marker,
M_Mark => Empty_Marker);
Mark (Syn_Inst.Objects (Info.Slot).M_Mark, Pool.all);
end Create_Object_Marker;
procedure Create_Object
(Syn_Inst : Synth_Instance_Acc; Decl : Node; Vt : Valtyp)
is
Info : constant Sim_Info_Acc := Get_Info (Decl);
begin
Create_Object (Syn_Inst, Info.Slot, 1);
Create_Object_Force (Syn_Inst, Decl, Vt);
end Create_Object;
procedure Create_Signal (Syn_Inst : Synth_Instance_Acc;
Decl : Node;
Typ : Type_Acc;
Init : Value_Acc)
is
Info : constant Sim_Info_Acc := Get_Info (Decl);
Vt : Valtyp;
begin
Create_Object (Syn_Inst, Info.Slot, 1);
Sig_Nbr := Sig_Nbr + 1;
Vt := (Typ, Create_Value_Signal (Sig_Nbr, Init));
Syn_Inst.Objects (Info.Slot) := (Kind => Obj_Object, Obj => Vt);
end Create_Signal;
procedure Replace_Signal
(Syn_Inst : Synth_Instance_Acc; Decl : Node; Vt : Valtyp)
is
Info : constant Sim_Info_Acc := Get_Info (Decl);
Obj : Obj_Type renames Syn_Inst.Objects (Info.Slot);
begin
pragma Assert (Obj.Kind = Obj_Object);
pragma Assert (Obj.Obj.Typ = Vt.Typ);
pragma Assert (Obj.Obj.Val.Kind = Value_Signal);
Obj.Obj := Vt;
-- TODO: free old signal ?
end Replace_Signal;
procedure Mutate_Object
(Syn_Inst : Synth_Instance_Acc; Decl : Node; Vt : Valtyp)
is
Info : constant Sim_Info_Acc := Get_Info (Decl);
Obj : Obj_Type renames Syn_Inst.Objects (Info.Slot);
begin
pragma Assert (Obj.Kind = Obj_Object);
pragma Assert (Obj.Obj.Typ = Vt.Typ);
Obj.Obj := Vt;
end Mutate_Object;
procedure Create_Sub_Instance (Syn_Inst : Synth_Instance_Acc;
Stmt : Node;
Sub_Inst : Synth_Instance_Acc)
is
Info : constant Sim_Info_Acc := Get_Info (Stmt);
begin
Create_Object (Syn_Inst, Info.Inst_Slot, 1);
pragma Assert (Syn_Inst.Objects (Info.Inst_Slot).Kind = Obj_None);
Syn_Inst.Objects (Info.Inst_Slot) := (Kind => Obj_Instance,
I_Inst => Sub_Inst);
end Create_Sub_Instance;
procedure Create_Component_Instance (Syn_Inst : Synth_Instance_Acc;
Sub_Inst : Synth_Instance_Acc)
is
Slot : constant Object_Slot_Type := Syn_Inst.Max_Objs;
begin
pragma Assert (Slot > 0);
pragma Assert (Syn_Inst.Objects (Slot).Kind = Obj_None);
Create_Object (Syn_Inst, Slot, 1);
Syn_Inst.Objects (Slot) := (Kind => Obj_Instance,
I_Inst => Sub_Inst);
end Create_Component_Instance;
procedure Create_Subtype_Object
(Syn_Inst : Synth_Instance_Acc; Decl : Node; Typ : Type_Acc)
is
pragma Assert (Typ /= null);
Info : constant Sim_Info_Acc := Get_Info (Decl);
begin
Create_Object (Syn_Inst, Info.Slot, 1);
pragma Assert (Syn_Inst.Objects (Info.Slot).Kind = Obj_None);
Syn_Inst.Objects (Info.Slot) := (Kind => Obj_Subtype, T_Typ => Typ);
end Create_Subtype_Object;
procedure Create_Package_Object (Syn_Inst : Synth_Instance_Acc;
Decl : Node;
Inst : Synth_Instance_Acc;
Is_Global : Boolean)
is
Info : constant Sim_Info_Acc := Get_Info (Decl);
begin
if Is_Global then
pragma Assert (Syn_Inst.Objects (Info.Pkg_Slot).Kind = Obj_None);
pragma Assert (Syn_Inst.Up_Block = null);
null;
else
pragma Assert (Syn_Inst.Up_Block /= null);
Create_Object (Syn_Inst, Info.Pkg_Slot, 1);
end if;
Syn_Inst.Objects (Info.Pkg_Slot) := (Kind => Obj_Instance,
I_Inst => Inst);
end Create_Package_Object;
procedure Create_Package_Interface (Syn_Inst : Synth_Instance_Acc;
Decl : Node;
Inst : Synth_Instance_Acc)
is
Info : constant Sim_Info_Acc := Get_Info (Decl);
begin
pragma Assert (Syn_Inst.Up_Block /= null);
Create_Object (Syn_Inst, Info.Pkg_Slot, 1);
Syn_Inst.Objects (Info.Pkg_Slot) := (Kind => Obj_Instance,
I_Inst => Inst);
end Create_Package_Interface;
function Get_Package_Object
(Syn_Inst : Synth_Instance_Acc; Info : Sim_Info_Acc)
return Synth_Instance_Acc
is
Parent : Synth_Instance_Acc;
begin
Parent := Get_Instance_By_Scope (Syn_Inst, Info.Pkg_Parent);
return Parent.Objects (Info.Pkg_Slot).I_Inst;
end Get_Package_Object;
function Get_Package_Object
(Syn_Inst : Synth_Instance_Acc; Pkg : Node) return Synth_Instance_Acc is
begin
return Get_Package_Object (Syn_Inst, Get_Info (Pkg));
end Get_Package_Object;
function Create_Package_Instance (Parent_Inst : Synth_Instance_Acc;
Pkg : Node)
return Synth_Instance_Acc
is
Syn_Inst : Synth_Instance_Acc;
begin
Syn_Inst := Make_Elab_Instance (Parent_Inst, Null_Node, Pkg, Null_Node);
if Get_Kind (Get_Parent (Pkg)) = Iir_Kind_Design_Unit then
-- Global package.
Create_Package_Object (Parent_Inst, Pkg, Syn_Inst, True);
else
-- Local package: check elaboration order.
Create_Package_Object (Parent_Inst, Pkg, Syn_Inst, False);
end if;
return Syn_Inst;
end Create_Package_Instance;
function Get_Sub_Instance
(Syn_Inst : Synth_Instance_Acc; Stmt : Node) return Synth_Instance_Acc
is
Info : constant Sim_Info_Acc := Get_Info (Stmt);
begin
return Syn_Inst.Objects (Info.Inst_Slot).I_Inst;
end Get_Sub_Instance;
function Get_Component_Instance
(Syn_Inst : Synth_Instance_Acc) return Synth_Instance_Acc
is
Slot : constant Object_Slot_Type := Syn_Inst.Max_Objs;
begin
return Syn_Inst.Objects (Slot).I_Inst;
end Get_Component_Instance;
procedure Set_Uninstantiated_Scope
(Syn_Inst : Synth_Instance_Acc; Bod : Node) is
begin
Syn_Inst.Uninst_Scope := Get_Info (Bod);
end Set_Uninstantiated_Scope;
procedure Destroy_Init (D : out Destroy_Type;
Syn_Inst : Synth_Instance_Acc) is
begin
D := (Inst => Syn_Inst,
First => Object_Slot_Type'Last,
Last => Syn_Inst.Elab_Objects);
end Destroy_Init;
procedure Destroy_Check (D : in out Destroy_Type; Info : Sim_Info_Acc)
is
Slot : constant Object_Slot_Type := Info.Slot;
begin
if Info.Obj_Scope /= D.Inst.Block_Scope then
-- Bad context.
raise Internal_Error;
end if;
if Slot > D.Last then
-- Not elaborated object ?
raise Internal_Error;
end if;
if D.Inst.Objects (Slot).Kind = Obj_None then
-- Already destroyed.
raise Internal_Error;
end if;
if Slot < D.First then
D.First := Slot;
end if;
end Destroy_Check;
procedure Destroy_Object (D : in out Destroy_Type; Decl : Node)
is
Info : constant Sim_Info_Acc := Get_Info (Decl);
begin
Destroy_Check (D, Info);
D.Inst.Objects (Info.Slot) := (Kind => Obj_None);
end Destroy_Object;
procedure Destroy_Marker
(D : in out Destroy_Type; N : Node; Pool : Areapools.Areapool_Acc)
is
use Areapools;
Info : constant Sim_Info_Acc := Get_Info (N);
Slot : constant Object_Slot_Type := Info.Slot;
begin
Destroy_Check (D, Info);
Release (D.Inst.Objects (Slot).M_Mark, Pool.all);
D.Inst.Objects (Slot) := (Kind => Obj_None);
end Destroy_Marker;
procedure Destroy_Finish (D : in out Destroy_Type) is
begin
if D.First = Object_Slot_Type'Last then
-- No object destroyed.
return;
end if;
if D.Last /= D.Inst.Elab_Objects then
-- Two destroys at the same time.
raise Internal_Error;
end if;
-- Check all objects have been destroyed.
for I in D.First .. D.Last loop
if D.Inst.Objects (I).Kind /= Obj_None then
raise Internal_Error;
end if;
end loop;
D.Inst.Elab_Objects := D.First - 1;
end Destroy_Finish;
function Get_Instance_By_Scope
(Syn_Inst: Synth_Instance_Acc; Scope: Sim_Info_Acc)
return Synth_Instance_Acc
is
pragma Assert (Scope /= null);
begin
case Scope.Kind is
when Kind_Block
| Kind_Frame
| Kind_Process
| Kind_Protected =>
declare
Current : Synth_Instance_Acc;
begin
Current := Syn_Inst;
while Current /= null loop
if Current.Block_Scope = Scope
or else Current.Uninst_Scope = Scope
then
return Current;
end if;
Current := Current.Up_Block;
end loop;
raise Internal_Error;
end;
when Kind_Package =>
if Scope.Pkg_Parent = null then
-- This is a scope for an uninstantiated package.
declare
Current : Synth_Instance_Acc;
begin
Current := Syn_Inst;
while Current /= null loop
if Current.Uninst_Scope = Scope then
return Current;
end if;
Current := Current.Up_Block;
end loop;
raise Internal_Error;
end;
else
-- Instantiated package.
return Get_Package_Object (Syn_Inst, Scope);
end if;
when others =>
raise Internal_Error;
end case;
end Get_Instance_By_Scope;
function Get_Info_Scope (Blk : Node) return Sim_Info_Acc
is
N : Node;
begin
if Get_Kind (Blk) = Iir_Kind_Architecture_Body then
N := Vhdl.Utils.Get_Entity (Blk);
else
N := Blk;
end if;
return Get_Info (N);
end Get_Info_Scope;
function Get_Parent_Scope (Blk : Node) return Sim_Info_Acc is
begin
return Get_Info_Scope (Get_Parent (Blk));
end Get_Parent_Scope;
function Get_Value (Syn_Inst: Synth_Instance_Acc; Obj : Node)
return Valtyp
is
Info : constant Sim_Info_Acc := Get_Info (Obj);
Obj_Inst : Synth_Instance_Acc;
begin
Obj_Inst := Get_Instance_By_Scope (Syn_Inst, Info.Obj_Scope);
return Obj_Inst.Objects (Info.Slot).Obj;
end Get_Value;
function Get_Subtype_Object
(Syn_Inst : Synth_Instance_Acc; Decl : Node) return Type_Acc
is
Info : constant Sim_Info_Acc := Get_Info (Decl);
Obj_Inst : Synth_Instance_Acc;
begin
Obj_Inst := Get_Instance_By_Scope (Syn_Inst, Info.Obj_Scope);
return Obj_Inst.Objects (Info.Slot).T_Typ;
end Get_Subtype_Object;
procedure Set_Caller_Instance (Syn_Inst : Synth_Instance_Acc;
Caller : Synth_Instance_Acc) is
begin
pragma Assert (Syn_Inst.Caller = null);
Syn_Inst.Caller := Caller;
end Set_Caller_Instance;
function Get_Caller_Instance (Syn_Inst : Synth_Instance_Acc)
return Synth_Instance_Acc is
begin
return Syn_Inst.Caller;
end Get_Caller_Instance;
procedure Iterate_Top_Level (It : in out Iterator_Top_Level_Type;
Res : out Synth_Instance_Acc)
is
Obj : Obj_Type;
begin
loop
if It.Next_Idx > Root_Instance.Max_Objs then
Res := null;
exit;
end if;
Obj := Root_Instance.Objects (It.Next_Idx);
It.Next_Idx := It.Next_Idx + 1;
if Obj.Kind = Obj_Instance then
Res := Obj.I_Inst;
return;
end if;
end loop;
end Iterate_Top_Level;
end Elab.Vhdl_Context;