-- Configuration generation.
-- 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 GHDL; see the file COPYING. If not, write to the Free
-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-- 02111-1307, USA.
with Name_Table; use Name_Table;
with Str_Table;
with Flags;
with Errorout; use Errorout;
with Libraries;
with Vhdl.Errors; use Vhdl.Errors;
with Vhdl.Std_Package;
with Vhdl.Utils; use Vhdl.Utils;
with Vhdl.Nodes_Walk;
with Vhdl.Sem_Scopes;
with Vhdl.Sem_Lib; use Vhdl.Sem_Lib;
with Vhdl.Canon;
with Vhdl.Evaluation;
package body Vhdl.Configuration is
procedure Add_Design_Concurrent_Stmts (Parent : Iir);
procedure Add_Design_Block_Configuration (Blk : Iir_Block_Configuration);
procedure Add_Design_Aspect (Aspect : Iir; Add_Default : Boolean);
Current_File_Dependence : Iir_List := Null_Iir_List;
Current_Configuration : Iir_Configuration_Declaration := Null_Iir;
-- UNIT is a design unit of a configuration declaration.
-- Fill the DESIGN_UNITS table with all design units required to build
-- UNIT.
procedure Add_Design_Unit (Unit : Iir_Design_Unit; From : Iir)
is
List : Iir_List;
It : List_Iterator;
El : Iir;
Lib_Unit : Iir;
File : Iir_Design_File;
Prev_File_Dependence : Iir_List;
begin
if Flag_Build_File_Dependence then
-- The current file depends on unit.
File := Get_Design_File (Unit);
if Current_File_Dependence /= Null_Iir_List then
-- (There is no dependency for default configuration).
Add_Element (Current_File_Dependence, File);
end if;
end if;
-- If already in the table, then nothing to do.
if Get_Configuration_Mark_Flag (Unit) then
-- There might be some direct recursions:
-- * the default configuration might be implicitly referenced by
-- a direct entity instantiation
-- * a configuration may be referenced by itself for a recursive
-- instantiation
pragma Assert (Get_Configuration_Done_Flag (Unit)
or else (Get_Kind (Get_Library_Unit (Unit))
= Iir_Kind_Configuration_Declaration));
return;
end if;
Set_Configuration_Mark_Flag (Unit, True);
-- May be enabled to debug dependency construction.
if False then
if From = Null_Iir then
Report_Msg (Msgid_Note, Elaboration, +Unit,
"%n added", (1 => +Unit));
else
Report_Msg (Msgid_Note, Elaboration, +From,
"%n added by %n", (+Unit, +From));
end if;
end if;
Lib_Unit := Get_Library_Unit (Unit);
if Flag_Build_File_Dependence then
-- Switch current_file_dependence to the design file of Unit.
Prev_File_Dependence := Current_File_Dependence;
if Get_Kind (Lib_Unit) = Iir_Kind_Configuration_Declaration
and then Get_Identifier (Lib_Unit) = Null_Identifier
then
-- Do not add dependence for default configuration.
Current_File_Dependence := Null_Iir_List;
else
File := Get_Design_File (Unit);
Current_File_Dependence := Get_File_Dependence_List (File);
-- Create a list if not yet created.
if Current_File_Dependence = Null_Iir_List then
Current_File_Dependence := Create_Iir_List;
Set_File_Dependence_List (File, Current_File_Dependence);
end if;
end if;
end if;
if Flag_Load_All_Design_Units then
Load_Design_Unit (Unit, From);
end if;
-- Add packages from depend list.
-- If Flag_Build_File_Dependences is set, add design units of the
-- dependence list are added, because of LRM 11.4 Analysis Order.
-- Note: a design unit may be referenced but unused.
-- (eg: component specification which does not apply).
List := Get_Dependence_List (Unit);
It := List_Iterate (List);
while Is_Valid (It) loop
El := Get_Element (It);
El := Libraries.Find_Design_Unit (El);
if El /= Null_Iir then
Lib_Unit := Get_Library_Unit (El);
if Flag_Build_File_Dependence then
Add_Design_Unit (El, Unit);
else
case Get_Kind (Lib_Unit) is
when Iir_Kinds_Package_Declaration
| Iir_Kind_Context_Declaration =>
Add_Design_Unit (El, Unit);
when others =>
null;
end case;
end if;
end if;
Next (It);
end loop;
-- Lib_Unit may have changed.
Lib_Unit := Get_Library_Unit (Unit);
case Iir_Kinds_Library_Unit (Get_Kind (Lib_Unit)) is
when Iir_Kind_Package_Declaration =>
-- Analyze the package declaration, so that Set_Package below
-- will set the full package (and not a stub).
Load_Design_Unit (Unit, From);
Lib_Unit := Get_Library_Unit (Unit);
when Iir_Kind_Package_Instantiation_Declaration =>
-- The uninstantiated package is part of the dependency.
null;
when Iir_Kind_Configuration_Declaration =>
-- Add entity and architecture.
-- find all sub-configuration
Load_Design_Unit (Unit, From);
Lib_Unit := Get_Library_Unit (Unit);
Add_Design_Unit (Get_Design_Unit (Get_Entity (Lib_Unit)), Unit);
declare
Blk : Iir_Block_Configuration;
Prev_Configuration : Iir_Configuration_Declaration;
Arch : Iir;
begin
Prev_Configuration := Current_Configuration;
Current_Configuration := Lib_Unit;
Blk := Get_Block_Configuration (Lib_Unit);
Add_Design_Block_Configuration (Blk);
Current_Configuration := Prev_Configuration;
Arch := Strip_Denoting_Name (Get_Block_Specification (Blk));
Add_Design_Unit (Get_Design_Unit (Arch), Unit);
end;
when Iir_Kind_Architecture_Body =>
-- Add entity
-- find all entity/architecture/configuration instantiation
Add_Design_Unit (Get_Design_Unit (Get_Entity (Lib_Unit)), Unit);
Add_Design_Concurrent_Stmts (Lib_Unit);
when Iir_Kind_Entity_Declaration
| Iir_Kind_Package_Body
| Iir_Kind_Context_Declaration
| Iir_Kinds_Verification_Unit =>
null;
end case;
-- Add it in the table, after the dependencies.
Design_Units.Append (Unit);
Set_Configuration_Done_Flag (Unit, True);
-- Restore now the file dependence.
-- Indeed, we may add a package body when we are in a package
-- declaration. However, the later does not depend on the former.
-- The file which depends on the package declaration also depends on
-- the package body.
if Flag_Build_File_Dependence then
Current_File_Dependence := Prev_File_Dependence;
end if;
if Get_Kind (Lib_Unit) = Iir_Kind_Package_Declaration then
-- Add body (if any).
declare
Bod : Iir_Design_Unit;
begin
Bod := Libraries.Find_Secondary_Unit (Unit, Null_Identifier);
if Get_Need_Body (Lib_Unit) then
if not Flags.Flag_Elaborate_With_Outdated then
-- LIB_UNIT requires a body.
if Bod = Null_Iir then
Error_Msg_Elab
(Lib_Unit, "body of %n was never analyzed", +Lib_Unit);
elsif Get_Date (Bod) < Get_Date (Unit) then
-- Cannot use BOD as location, as the location may not
-- exist.
Error_Msg_Elab (Lib_Unit, "%n is outdated", +Bod);
Bod := Null_Iir;
end if;
end if;
else
if Bod /= Null_Iir
and then Get_Date (Bod) < Get_Date (Unit)
then
-- There is a body for LIB_UNIT (which doesn't
-- require it) but it is outdated.
Bod := Null_Iir;
end if;
end if;
if Bod /= Null_Iir then
Set_Package (Get_Library_Unit (Bod), Lib_Unit);
Add_Design_Unit (Bod, Unit);
end if;
end;
end if;
end Add_Design_Unit;
procedure Add_Design_Concurrent_Stmts (Parent : Iir)
is
Stmt : Iir;
begin
Stmt := Get_Concurrent_Statement_Chain (Parent);
while Stmt /= Null_Iir loop
case Get_Kind (Stmt) is
when Iir_Kind_Component_Instantiation_Statement =>
if Is_Entity_Instantiation (Stmt) then
-- Entity or configuration instantiation.
Add_Design_Aspect (Get_Instantiated_Unit (Stmt), True);
end if;
when Iir_Kind_Block_Statement =>
Add_Design_Concurrent_Stmts (Stmt);
when Iir_Kind_For_Generate_Statement =>
Add_Design_Concurrent_Stmts
(Get_Generate_Statement_Body (Stmt));
when Iir_Kind_If_Generate_Statement =>
declare
Clause : Iir;
begin
Clause := Stmt;
while Clause /= Null_Iir loop
Add_Design_Concurrent_Stmts
(Get_Generate_Statement_Body (Clause));
Clause := Get_Generate_Else_Clause (Clause);
end loop;
end;
when Iir_Kind_Case_Generate_Statement =>
declare
Alt : Iir;
begin
Alt := Get_Case_Statement_Alternative_Chain (Stmt);
while Alt /= Null_Iir loop
if not Get_Same_Alternative_Flag (Alt) then
Add_Design_Concurrent_Stmts
(Get_Associated_Block (Alt));
end if;
Alt := Get_Chain (Alt);
end loop;
end;
when Iir_Kinds_Simple_Concurrent_Statement
| Iir_Kind_Psl_Default_Clock
| Iir_Kind_Psl_Declaration
| Iir_Kind_Psl_Endpoint_Declaration
| Iir_Kind_Simple_Simultaneous_Statement =>
null;
when others =>
Error_Kind ("add_design_concurrent_stmts(2)", Stmt);
end case;
Stmt := Get_Chain (Stmt);
end loop;
end Add_Design_Concurrent_Stmts;
procedure Add_Design_Aspect (Aspect : Iir; Add_Default : Boolean)
is
use Libraries;
Entity : Iir;
Arch_Name : Iir;
Arch : Iir;
Config : Iir;
Arch_Lib : Iir;
Id : Name_Id;
Entity_Lib : Iir;
begin
if Aspect = Null_Iir then
return;
end if;
case Get_Kind (Aspect) is
when Iir_Kind_Entity_Aspect_Entity =>
-- Add the entity.
Entity_Lib := Get_Entity (Aspect);
if Entity_Lib = Null_Iir then
-- In case of error (using -c).
return;
end if;
Entity := Get_Design_Unit (Entity_Lib);
Add_Design_Unit (Entity, Aspect);
-- Extract and add the architecture.
Arch_Name := Get_Architecture (Aspect);
if Arch_Name /= Null_Iir then
case Get_Kind (Arch_Name) is
when Iir_Kind_Simple_Name =>
Id := Get_Identifier (Arch_Name);
Arch := Load_Secondary_Unit (Entity, Id, Aspect);
if Arch = Null_Iir then
Error_Msg_Elab ("cannot find architecture %i of %n",
(+Id, +Entity_Lib));
return;
else
Set_Named_Entity (Arch_Name, Get_Library_Unit (Arch));
end if;
when Iir_Kind_Reference_Name =>
Arch := Get_Design_Unit (Get_Named_Entity (Arch_Name));
when others =>
Error_Kind ("add_design_aspect", Arch_Name);
end case;
else
Arch := Get_Latest_Architecture (Entity_Lib);
if Arch = Null_Iir then
Error_Msg_Elab (Aspect, "no architecture in library for %n",
+Entity_Lib);
return;
end if;
Arch := Get_Design_Unit (Arch);
end if;
Load_Design_Unit (Arch, Aspect);
-- Add the default configuration if required. Must be done
-- before the architecture in case of recursive instantiation:
-- the configuration depends on the architecture.
if Add_Default then
Arch_Lib := Get_Library_Unit (Arch);
-- The default configuration may already exist due to a
-- previous instantiation. Create it if it doesn't exist.
Config := Get_Default_Configuration_Declaration (Arch_Lib);
if Is_Null (Config) then
Config := Vhdl.Canon.Create_Default_Configuration_Declaration
(Arch_Lib);
Set_Default_Configuration_Declaration (Arch_Lib, Config);
end if;
if Get_Configuration_Mark_Flag (Config)
and then not Get_Configuration_Done_Flag (Config)
then
-- Recursive instantiation.
return;
else
Add_Design_Unit (Config, Aspect);
end if;
end if;
-- Otherwise, simply the architecture.
Add_Design_Unit (Arch, Aspect);
when Iir_Kind_Entity_Aspect_Configuration =>
Add_Design_Unit
(Get_Design_Unit (Get_Configuration (Aspect)), Aspect);
when Iir_Kind_Entity_Aspect_Open =>
null;
when others =>
Error_Kind ("add_design_aspect", Aspect);
end case;
end Add_Design_Aspect;
-- Return TRUE is PORT must not be open, and emit an error message only if
-- LOC is not NULL_IIR.
function Check_Open_Port (Port : Iir; Loc : Iir) return Boolean is
begin
case Get_Mode (Port) is
when Iir_In_Mode =>
-- LRM93 1.1.1.2 Ports
-- A port of mode IN may be unconnected or unassociated only if
-- its declaration includes a default expression.
if Get_Default_Value (Port) = Null_Iir then
if Loc /= Null_Iir then
Error_Msg_Elab_Relaxed
(Loc, Warnid_Port,
"IN %n must be connected (or have a default value)",
(1 => +Port));
end if;
return True;
end if;
when Iir_Out_Mode
| Iir_Inout_Mode
| Iir_Buffer_Mode
| Iir_Linkage_Mode =>
-- LRM93 1.1.1.2 Ports
-- A port of any mode other than IN may be unconnected or
-- unassociated as long as its type is not an unconstrained array
-- type.
if Get_Kind (Get_Type (Port)) in Iir_Kinds_Array_Type_Definition
and then (Get_Constraint_State (Get_Type (Port))
/= Fully_Constrained)
then
if Loc /= Null_Iir then
Error_Msg_Elab
(Loc, "unconstrained %n must be connected", +Port);
end if;
return True;
end if;
when Iir_Unknown_Mode =>
raise Internal_Error;
end case;
return False;
end Check_Open_Port;
procedure Check_Binding_Indication (Conf : Iir)
is
Comp : constant Iir := Get_Named_Entity (Get_Component_Name (Conf));
Bind : constant Iir_Binding_Indication := Get_Binding_Indication (Conf);
Aspect : constant Iir := Get_Entity_Aspect (Bind);
Ent : constant Iir := Get_Entity_From_Entity_Aspect (Aspect);
Assoc_Chain : constant Iir := Get_Port_Map_Aspect_Chain (Bind);
Inter_Chain : constant Iir := Get_Port_Chain (Ent);
Assoc : Iir;
Inter : Iir;
Inst_Assoc_Chain : Iir;
Inst_Inter_Chain : Iir;
Err : Boolean;
Inst : Iir;
Inst_List : Iir_Flist;
Formal : Iir;
Assoc_1 : Iir;
Inter_1 : Iir;
Actual : Iir;
begin
Err := False;
-- Note: the assoc chain is already canonicalized.
-- First pass: check for open associations in configuration.
Assoc := Assoc_Chain;
Inter := Inter_Chain;
while Assoc /= Null_Iir loop
if Get_Kind (Assoc) = Iir_Kind_Association_Element_Open then
Formal := Get_Association_Interface (Assoc, Inter);
Err := Err or Check_Open_Port (Formal, Assoc);
if Is_Warning_Enabled (Warnid_Binding)
and then not Get_Artificial_Flag (Assoc)
then
Report_Start_Group;
Warning_Msg_Elab
(Warnid_Binding, Assoc, "%n of %n is not bound",
(+Formal, +Get_Parent (Formal)));
Warning_Msg_Elab
(Warnid_Binding, Current_Configuration,
"(in %n)", +Current_Configuration);
Report_End_Group;
end if;
end if;
Next_Association_Interface (Assoc, Inter);
end loop;
if Err then
return;
end if;
-- Second pass: check for port connected to open in instantiation.
Inst_List := Get_Instantiation_List (Conf);
for I in Flist_First .. Flist_Last (Inst_List) loop
Inst := Get_Nth_Element (Inst_List, I);
Inst := Get_Named_Entity (Inst);
Err := False;
-- Mark component ports not associated.
Inst_Assoc_Chain := Get_Port_Map_Aspect_Chain (Inst);
Inst_Inter_Chain := Get_Port_Chain (Comp);
Assoc := Inst_Assoc_Chain;
Inter := Inst_Inter_Chain;
while Assoc /= Null_Iir loop
if Get_Kind (Assoc) = Iir_Kind_Association_Element_Open then
Formal := Get_Association_Interface (Assoc, Inter);
Set_Open_Flag (Formal, True);
Err := True;
end if;
Next_Association_Interface (Assoc, Inter);
end loop;
-- If there is any component port open, search them in the
-- configuration.
if Err then
Assoc := Assoc_Chain;
Inter := Inter_Chain;
while Assoc /= Null_Iir loop
Formal := Get_Association_Interface (Assoc, Inter);
if Get_Kind (Assoc) = Iir_Kind_Association_Element_Open then
Actual := Null_Iir;
else
Actual := Get_Actual (Assoc);
Actual := Name_To_Object (Actual);
if Actual /= Null_Iir then
Actual := Get_Object_Prefix (Actual);
end if;
end if;
if Actual /= Null_Iir
and then Get_Open_Flag (Actual)
and then Check_Open_Port (Formal, Null_Iir)
then
-- For a better message, find the location.
Assoc_1 := Inst_Assoc_Chain;
Inter_1 := Inst_Inter_Chain;
while Assoc_1 /= Null_Iir loop
if Get_Kind (Assoc_1) = Iir_Kind_Association_Element_Open
and then
Actual = Get_Association_Interface (Assoc_1, Inter_1)
then
Err := Check_Open_Port (Formal, Assoc_1);
exit;
end if;
Next_Association_Interface (Assoc_1, Inter_1);
end loop;
end if;
Next_Association_Interface (Assoc, Inter);
end loop;
-- Clear open flag.
Assoc := Inst_Assoc_Chain;
Inter := Inst_Inter_Chain;
while Assoc /= Null_Iir loop
if Get_Kind (Assoc) = Iir_Kind_Association_Element_Open then
Formal := Get_Association_Interface (Assoc, Inter);
Set_Open_Flag (Formal, False);
end if;
Next_Association_Interface (Assoc, Inter);
end loop;
end if;
end loop;
end Check_Binding_Indication;
function Is_In_Vendor_Library (Inst : Iir) return Boolean
is
Parent : Iir;
begin
Parent := Strip_Denoting_Name (Inst);
loop
Parent := Get_Parent (Parent);
if Get_Kind (Parent) = Iir_Kind_Library_Declaration then
return Get_Vendor_Library_Flag (Parent);
end if;
end loop;
end Is_In_Vendor_Library;
-- CONF is either a configuration specification or a component
-- configuration.
-- If ADD_DEFAULT is true, then the default configuration for the design
-- binding must be added if required.
procedure Add_Design_Binding_Indication (Conf : Iir; Add_Default : Boolean)
is
Bind : constant Iir_Binding_Indication := Get_Binding_Indication (Conf);
Aspect : Iir;
Inst : Iir;
Comp : Iir;
begin
if Bind = Null_Iir then
if Is_Warning_Enabled (Warnid_Binding) then
Inst := Get_Nth_Element (Get_Instantiation_List (Conf), 0);
Inst := Strip_Denoting_Name (Inst);
Comp := Get_Instantiated_Unit (Inst);
if not Is_In_Vendor_Library (Comp) then
Report_Start_Group;
Warning_Msg_Elab (Warnid_Binding, Conf,
"instance %i of component %i is not bound",
(+Inst, +Comp));
Warning_Msg_Elab (Warnid_Binding, Current_Configuration,
"(in %n)", +Current_Configuration);
Report_End_Group;
end if;
end if;
return;
end if;
Aspect := Get_Entity_Aspect (Bind);
if Is_Valid (Aspect)
and then Get_Kind (Aspect) /= Iir_Kind_Entity_Aspect_Open
then
Check_Binding_Indication (Conf);
Add_Design_Aspect (Aspect, Add_Default);
end if;
end Add_Design_Binding_Indication;
procedure Add_Design_Block_Configuration (Blk : Iir_Block_Configuration)
is
Item : Iir;
Sub_Config : Iir;
begin
if Blk = Null_Iir then
return;
end if;
Item := Get_Configuration_Item_Chain (Blk);
while Item /= Null_Iir loop
case Get_Kind (Item) is
when Iir_Kind_Configuration_Specification =>
Add_Design_Binding_Indication (Item, True);
when Iir_Kind_Component_Configuration =>
Sub_Config := Get_Block_Configuration (Item);
Add_Design_Binding_Indication (Item, Sub_Config = Null_Iir);
Add_Design_Block_Configuration (Sub_Config);
when Iir_Kind_Block_Configuration =>
Add_Design_Block_Configuration (Item);
when others =>
Error_Kind ("add_design_block_configuration", Item);
end case;
Item := Get_Chain (Item);
end loop;
end Add_Design_Block_Configuration;
-- elaboration of a design hierarchy:
-- creates a list of design unit.
--
-- find top configuration (may be a default one), add it to the list.
-- For each element of the list:
-- add direct dependences (packages, entity, arch) if not in the list
-- for architectures and configuration: find instantiations and add
-- corresponding configurations.
--
-- Return the configuration declaration for the design.
function Configure (Primary_Id : Name_Id; Secondary_Id : Name_Id)
return Iir
is
use Libraries;
Unit : Iir_Design_Unit;
Lib_Unit : Iir;
Top : Iir;
begin
Unit := Find_Primary_Unit (Work_Library, Primary_Id);
if Unit = Null_Iir then
Error_Msg_Elab ("cannot find entity or configuration "
& Name_Table.Image (Primary_Id));
return Null_Iir;
end if;
Lib_Unit := Get_Library_Unit (Unit);
case Get_Kind (Lib_Unit) is
when Iir_Kind_Entity_Declaration =>
-- Use WORK as location (should use a command line location ?)
Load_Design_Unit (Unit, Work_Library);
Lib_Unit := Get_Library_Unit (Unit);
if Secondary_Id /= Null_Identifier then
Unit := Find_Secondary_Unit (Unit, Secondary_Id);
if Unit = Null_Iir then
Error_Msg_Elab ("cannot find architecture %i of %n",
(+Secondary_Id, +Lib_Unit));
return Null_Iir;
end if;
else
declare
Arch_Unit : Iir_Architecture_Body;
begin
Arch_Unit := Get_Latest_Architecture (Lib_Unit);
if Arch_Unit = Null_Iir then
Error_Msg_Elab
("%n has no architecture in library %i",
(+Lib_Unit, +Work_Library));
return Null_Iir;
end if;
Unit := Get_Design_Unit (Arch_Unit);
end;
end if;
Load_Design_Unit (Unit, Lib_Unit);
if Nbr_Errors /= 0 then
return Null_Iir;
end if;
Lib_Unit := Get_Library_Unit (Unit);
pragma Assert
(Is_Null (Get_Default_Configuration_Declaration (Lib_Unit)));
Top := Vhdl.Canon.Create_Default_Configuration_Declaration
(Lib_Unit);
Set_Default_Configuration_Declaration (Lib_Unit, Top);
pragma Assert (Is_Valid (Top));
when Iir_Kind_Configuration_Declaration =>
if Secondary_Id /= Null_Identifier then
Error_Msg_Elab
("no secondary unit allowed after configuration %i",
+Primary_Id);
return Null_Iir;
end if;
Top := Unit;
when others =>
Error_Msg_Elab ("%i is neither an entity nor a configuration",
+Primary_Id);
return Null_Iir;
end case;
-- Exclude std.standard
Set_Configuration_Mark_Flag (Vhdl.Std_Package.Std_Standard_Unit, True);
Set_Configuration_Done_Flag (Vhdl.Std_Package.Std_Standard_Unit, True);
Add_Design_Unit (Top, Null_Iir);
return Top;
end Configure;
procedure Add_Verification_Unit (Vunit : Iir)
is
Hier_Name : constant Iir := Get_Hierarchical_Name (Vunit);
Name : Iir;
begin
-- Not bound.
if Hier_Name = Null_Iir then
return;
end if;
Name := Get_Architecture (Hier_Name);
if Name /= Null_Node then
Name := Get_Named_Entity (Name);
pragma Assert (Get_Kind (Name) = Iir_Kind_Architecture_Body);
else
Name := Get_Entity_Name (Hier_Name);
Name := Get_Named_Entity (Name);
pragma Assert (Get_Kind (Name) = Iir_Kind_Entity_Declaration);
end if;
if not Get_Configuration_Mark_Flag (Get_Design_Unit (Name)) then
-- Not for a configured unit.
return;
end if;
Set_Bound_Vunit_Chain (Vunit, Get_Bound_Vunit_Chain (Name));
Set_Bound_Vunit_Chain (Name, Vunit);
Add_Design_Unit (Get_Design_Unit (Vunit), Vunit);
end Add_Verification_Unit;
procedure Add_Verification_Units
is
Library : Iir;
File : Iir;
Unit : Iir;
Lib : Iir;
begin
-- For each units:
Library := Libraries.Get_Libraries_Chain;
while Library /= Null_Iir loop
File := Get_Design_File_Chain (Library);
while File /= Null_Iir loop
Unit := Get_First_Design_Unit (File);
while Unit /= Null_Iir loop
Lib := Get_Library_Unit (Unit);
if Get_Kind (Lib) = Iir_Kind_Vunit_Declaration then
-- Load it.
Load_Design_Unit (Unit, Unit);
Add_Verification_Unit (Get_Library_Unit (Unit));
end if;
Unit := Get_Chain (Unit);
end loop;
File := Get_Chain (File);
end loop;
Library := Get_Chain (Library);
end loop;
end Add_Verification_Units;
procedure Check_Entity_Declaration_Top
(Entity : Iir_Entity_Declaration; Enable_Override : Boolean)
is
Has_Error : Boolean := False;
-- Return TRUE if GRT supports override of generic GEN.
function Allow_Generic_Override (Gen : Iir) return Boolean
is
Gen_Type : constant Iir := Get_Type (Gen);
begin
case Get_Kind (Gen_Type) is
when Iir_Kind_Integer_Type_Definition
| Iir_Kind_Integer_Subtype_Definition
| Iir_Kind_Enumeration_Type_Definition
| Iir_Kind_Enumeration_Subtype_Definition =>
return True;
when Iir_Kind_Array_Type_Definition
| Iir_Kind_Array_Subtype_Definition =>
-- Only one-dimensional arrays of enumeration are allowed.
-- If unconstrained, the index must be of integer type.
if Get_Kind (Get_Base_Type (Get_Element_Subtype (Gen_Type)))
/= Iir_Kind_Enumeration_Type_Definition
then
-- Not an array of enumeration type.
return False;
end if;
declare
Indexes : constant Iir_Flist :=
Get_Index_Subtype_List (Gen_Type);
begin
if Get_Nbr_Elements (Indexes) /= 1 then
-- Not a one-dimensional array.
return False;
end if;
if Get_Constraint_State (Gen_Type) /= Fully_Constrained
and then (Get_Kind (Get_Index_Type (Indexes, 0))
/= Iir_Kind_Integer_Subtype_Definition)
then
-- Index not constrained or not of integer subtype.
return False;
end if;
end;
return True;
when others =>
return False;
end case;
end Allow_Generic_Override;
procedure Error (Loc : Iir; Msg : String; Arg1 : Earg_Type) is
begin
if not Has_Error then
Error_Msg_Elab ("%n cannot be at the top of a design", +Entity);
Has_Error := True;
end if;
Error_Msg_Elab (Loc, Msg, Arg1);
end Error;
El : Iir;
begin
-- Check generics.
El := Get_Generic_Chain (Entity);
while El /= Null_Iir loop
if Get_Default_Value (El) = Null_Iir then
if not (Enable_Override and Allow_Generic_Override (El)) then
Error (El, "(%n has no default value)", +El);
end if;
end if;
El := Get_Chain (El);
end loop;
-- Check port.
El := Get_Port_Chain (Entity);
while El /= Null_Iir loop
if not Is_Fully_Constrained_Type (Get_Type (El))
and then Get_Default_Value (El) = Null_Iir
then
Error (El, "(%n is unconstrained and has no default value)", +El);
end if;
El := Get_Chain (El);
end loop;
end Check_Entity_Declaration_Top;
package Top is
procedure Mark_Instantiated_Units (Lib : Iir_Library_Declaration);
Nbr_Top_Entities : Natural;
First_Top_Entity : Iir;
procedure Find_First_Top_Entity (Lib : Iir_Library_Declaration);
end Top;
package body Top is
use Nodes_Walk;
-- Add entities to the name table (so that they easily could be found).
function Add_Entity_Cb (Design : Iir) return Walk_Status
is
Kind : constant Iir_Kind := Get_Kind (Get_Library_Unit (Design));
begin
if not Flags.Flag_Elaborate_With_Outdated then
-- Discard obsolete or non-analyzed units.
if Get_Date (Design) < Date_Analyzed then
return Walk_Continue;
end if;
end if;
case Iir_Kinds_Library_Unit (Kind) is
when Iir_Kind_Architecture_Body
| Iir_Kind_Configuration_Declaration =>
Load_Design_Unit (Design, Null_Iir);
when Iir_Kind_Entity_Declaration =>
Load_Design_Unit (Design, Null_Iir);
Vhdl.Sem_Scopes.Add_Name (Get_Library_Unit (Design));
when Iir_Kind_Package_Declaration
| Iir_Kind_Package_Instantiation_Declaration
| Iir_Kind_Package_Body
| Iir_Kinds_Verification_Unit
| Iir_Kind_Context_Declaration =>
null;
end case;
return Walk_Continue;
end Add_Entity_Cb;
procedure Mark_Aspect (Aspect : Iir)
is
Unit : Iir;
begin
case Iir_Kinds_Entity_Aspect (Get_Kind (Aspect)) is
when Iir_Kind_Entity_Aspect_Entity =>
Unit := Get_Entity (Aspect);
if Unit /= Null_Node then
-- There may be an error (unit not found).
Set_Elab_Flag (Get_Parent (Unit), True);
end if;
when Iir_Kind_Entity_Aspect_Configuration
| Iir_Kind_Entity_Aspect_Open =>
null;
end case;
end Mark_Aspect;
function Mark_Instantiation_Cb (Stmt : Iir) return Walk_Status
is
Inst : Iir;
begin
if Get_Kind (Stmt) /= Iir_Kind_Component_Instantiation_Statement then
return Walk_Continue;
end if;
Inst := Get_Instantiated_Unit (Stmt);
case Get_Kind (Inst) is
when Iir_Kinds_Denoting_Name =>
-- TODO: look at default_binding_indication
-- or configuration_specification ?
declare
Config : constant Iir :=
Get_Configuration_Specification (Stmt);
begin
if Is_Valid (Config) then
Mark_Aspect
(Get_Entity_Aspect (Get_Binding_Indication (Config)));
return Walk_Continue;
end if;
end;
declare
use Vhdl.Sem_Scopes;
Comp : constant Iir := Get_Named_Entity (Inst);
Interp : Name_Interpretation_Type;
Decl : Iir;
begin
if Is_Error (Comp) then
return Walk_Continue;
end if;
Interp := Get_Interpretation (Get_Identifier (Comp));
if Valid_Interpretation (Interp) then
Decl := Get_Declaration (Interp);
pragma Assert
(Get_Kind (Decl) = Iir_Kind_Entity_Declaration);
Set_Elab_Flag (Get_Design_Unit (Decl), True);
else
-- If there is no corresponding entity name for the
-- component name, assume it belongs to a different
-- library (or will be set by a configuration unit).
null;
end if;
end;
when Iir_Kinds_Entity_Aspect =>
Mark_Aspect (Inst);
when others =>
Error_Kind ("mark_instantiation_cb", Stmt);
end case;
return Walk_Continue;
end Mark_Instantiation_Cb;
function Mark_Units_Cb (Design : Iir) return Walk_Status
is
Unit : constant Iir := Get_Library_Unit (Design);
Status : Walk_Status;
begin
if not Flags.Flag_Elaborate_With_Outdated then
if Get_Date (Design) < Date_Analyzed then
-- Skip outdated units.
return Walk_Continue;
end if;
end if;
case Iir_Kinds_Library_Unit (Get_Kind (Unit)) is
when Iir_Kind_Architecture_Body =>
Status := Walk_Concurrent_Statements_Chain
(Get_Concurrent_Statement_Chain (Unit),
Mark_Instantiation_Cb'Access);
pragma Assert (Status = Walk_Continue);
when Iir_Kind_Configuration_Declaration =>
-- Just ignored.
null;
when Iir_Kind_Package_Declaration
| Iir_Kind_Package_Instantiation_Declaration
| Iir_Kind_Package_Body
| Iir_Kind_Entity_Declaration
| Iir_Kinds_Verification_Unit
| Iir_Kind_Context_Declaration =>
null;
end case;
return Walk_Continue;
end Mark_Units_Cb;
procedure Mark_Instantiated_Units (Lib : Iir_Library_Declaration)
is
Status : Walk_Status;
begin
-- Name table is used to map names to entities.
Vhdl.Sem_Scopes.Push_Interpretations;
Vhdl.Sem_Scopes.Open_Declarative_Region;
-- 1. Add all design entities in the name table.
Status := Walk_Design_Units (Lib, Add_Entity_Cb'Access);
pragma Assert (Status = Walk_Continue);
-- 2. Walk architecture and configurations, and mark instantiated
-- entities.
Status := Walk_Design_Units (Lib, Mark_Units_Cb'Access);
pragma Assert (Status = Walk_Continue);
Vhdl.Sem_Scopes.Close_Declarative_Region;
Vhdl.Sem_Scopes.Pop_Interpretations;
end Mark_Instantiated_Units;
function Extract_Entity_Cb (Design : Iir) return Walk_Status
is
Unit : constant Iir := Get_Library_Unit (Design);
begin
if Get_Kind (Unit) = Iir_Kind_Entity_Declaration then
if Get_Elab_Flag (Design) then
-- Clean elab flag.
Set_Elab_Flag (Design, False);
else
if Flags.Verbose then
Report_Msg (Msgid_Note, Elaboration, +Unit,
"candidate for top entity: %n", (1 => +Unit));
end if;
Nbr_Top_Entities := Nbr_Top_Entities + 1;
if Nbr_Top_Entities = 1 then
First_Top_Entity := Unit;
end if;
end if;
end if;
return Walk_Continue;
end Extract_Entity_Cb;
procedure Find_First_Top_Entity (Lib : Iir_Library_Declaration)
is
Status : Walk_Status;
begin
Nbr_Top_Entities := 0;
First_Top_Entity := Null_Iir;
Status := Walk_Design_Units (Lib, Extract_Entity_Cb'Access);
pragma Assert (Status = Walk_Continue);
end Find_First_Top_Entity;
end Top;
function Find_Top_Entity (From : Iir) return Iir is
begin
-- FROM is a library or a design file.
Top.Mark_Instantiated_Units (From);
Top.Find_First_Top_Entity (From);
if Top.Nbr_Top_Entities = 1 then
return Top.First_Top_Entity;
else
return Null_Iir;
end if;
end Find_Top_Entity;
type Override_Entry is record
Gen : Name_Id;
Value : String_Acc;
end record;
package Override_Table is new Tables
(Table_Component_Type => Override_Entry,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 16);
procedure Add_Generic_Override (Id : Name_Id; Value : String) is
begin
Override_Table.Append (Override_Entry'(Gen => Id,
Value => new String'(Value)));
end Add_Generic_Override;
function Override_String_Generic
(Value : String_Acc; Formal_Type : Iir) return Iir
is
use Str_Table;
use Vhdl.Evaluation;
El_Type : constant Iir :=
Get_Base_Type (Get_Element_Subtype (Formal_Type));
F : constant Positive := Value'First;
Elist : Iir_Flist;
Res : Iir;
Str8 : String8_Id;
Ntype : Iir;
Len : Int32;
begin
if Get_Kind (El_Type) /= Iir_Kind_Enumeration_Type_Definition then
return Null_Iir;
end if;
Elist := Get_Enumeration_Literal_List (El_Type);
Str8 := Create_String8;
if Value'Last >= F + 2
and then (Value (F) = 'x' or Value (F) = 'X')
and then Value (F + 1) = '"'
and then Value (Value'Last) = '"'
then
-- Hexa string.
declare
C : Character;
V : Natural;
E0, E1 : Iir;
E : Iir;
begin
E0 := Find_Name_In_Flist (Elist, Get_Identifier ('0'));
E1 := Find_Name_In_Flist (Elist, Get_Identifier ('1'));
if E0 = Null_Iir or E1 = Null_Iir then
return Null_Iir;
end if;
Len := 0;
for I in F + 2 .. Value'Last - 1 loop
C := Value (I);
case C is
when '0' .. '9' =>
V := Character'Pos (C) - Character'Pos ('0');
when 'A' .. 'F' =>
V := Character'Pos (C) - Character'Pos ('A') + 10;
when 'a' .. 'f' =>
V := Character'Pos (C) - Character'Pos ('a') + 10;
when '_' =>
V := 16;
when others =>
Error_Msg_Elab ("incorrect character in bit string");
V := 16;
end case;
if V < 16 then
Len := Len + 4;
for J in 1 .. 4 loop
if V >= 8 then
E := E1;
V := V - 8;
else
E := E0;
end if;
Append_String8 (Nat8 (Get_Enum_Pos (E)));
V := V * 2;
end loop;
end if;
end loop;
end;
else
Append_String8_String (Value.all);
Len := Value'Length;
end if;
Res := Create_Iir (Iir_Kind_String_Literal8);
Set_String8_Id (Res, Str8);
-- FIXME: check characters are in the type.
Set_String_Length (Res, Len);
Set_Expr_Staticness (Res, Locally);
Ntype := Create_Unidim_Array_By_Length
(Get_Base_Type (Formal_Type), Value'Length, Res);
Set_Type (Res, Ntype);
Set_Literal_Subtype (Res, Ntype);
return Res;
end Override_String_Generic;
procedure Override_Generic (Gen : Iir; Value : String_Acc)
is
use Vhdl.Evaluation;
Formal_Type : constant Iir := Get_Type (Gen);
Formal_Btype : constant Iir := Get_Base_Type (Formal_Type);
Res : Iir;
begin
case Get_Kind (Formal_Btype) is
when Iir_Kind_Integer_Type_Definition
| Iir_Kind_Enumeration_Type_Definition =>
Res := Eval_Value_Attribute (Value.all, Formal_Type, Gen);
if not Eval_Is_In_Bound (Res, Formal_Type) then
Error_Msg_Elab ("override for %n is out of bounds", +Gen);
return;
end if;
Set_Literal_Origin (Res, Null_Iir);
when Iir_Kind_Array_Type_Definition =>
if Is_One_Dimensional_Array_Type (Formal_Btype) then
Res := Override_String_Generic (Value, Formal_Type);
else
Res := Null_Iir;
end if;
when others =>
Res := Null_Iir;
end case;
if Res = Null_Iir then
Error_Msg_Elab ("unhandled override for %n", +Gen);
end if;
if Get_Is_Ref (Gen) then
Set_Is_Ref (Gen, False);
else
if Get_Has_Identifier_List (Gen) then
-- Transfer ownership to the next interface.
Set_Is_Ref (Get_Chain (Gen), False);
end if;
end if;
Set_Location (Res, No_Location);
Set_Default_Value (Gen, Res);
end Override_Generic;
procedure Apply_Generic_Override (Ent : Iir)
is
Inter_Chain : constant Iir := Get_Generic_Chain (Ent);
Inter : Iir;
begin
for I in Override_Table.First .. Override_Table.Last loop
declare
Over : constant Override_Entry := Override_Table.Table (I);
begin
Inter := Inter_Chain;
while Inter /= Null_Iir loop
exit when Get_Identifier (Inter) = Over.Gen;
Inter := Get_Chain (Inter);
end loop;
if Inter = Null_Iir then
Error_Msg_Elab ("no generic %i for -g", +Over.Gen);
elsif Get_Kind (Inter) /= Iir_Kind_Interface_Constant_Declaration
then
Error_Msg_Elab
("generic %n cannot be overriden (not a constant)",
+Over.Gen);
else
Override_Generic (Inter, Over.Value);
end if;
end;
end loop;
end Apply_Generic_Override;
end Vhdl.Configuration;