diff options
author | Tristan Gingold <tgingold@free.fr> | 2017-07-05 08:04:17 +0200 |
---|---|---|
committer | Tristan Gingold <tgingold@free.fr> | 2017-07-05 08:04:17 +0200 |
commit | 271edd6024b2c91c8330e4388998145b3b622601 (patch) | |
tree | 117794acdf6b33fe2520e75c5a18258a1d986003 /src | |
parent | 482e59f6ec6f3ff1d92c384d1a13aafac34de648 (diff) | |
download | ghdl-271edd6024b2c91c8330e4388998145b3b622601.tar.gz ghdl-271edd6024b2c91c8330e4388998145b3b622601.tar.bz2 ghdl-271edd6024b2c91c8330e4388998145b3b622601.zip |
Add ghdl --find-top command.
Diffstat (limited to 'src')
-rw-r--r-- | src/ghdldrv/ghdllocal.adb | 57 | ||||
-rw-r--r-- | src/libraries.adb | 15 | ||||
-rw-r--r-- | src/libraries.ads | 6 | ||||
-rw-r--r-- | src/vhdl/configuration.adb | 198 | ||||
-rw-r--r-- | src/vhdl/configuration.ads | 5 | ||||
-rw-r--r-- | src/vhdl/iirs_walk.adb | 56 | ||||
-rw-r--r-- | src/vhdl/iirs_walk.ads | 8 |
7 files changed, 345 insertions, 0 deletions
diff --git a/src/ghdldrv/ghdllocal.adb b/src/ghdldrv/ghdllocal.adb index 81c3adb05..75ececd4f 100644 --- a/src/ghdldrv/ghdllocal.adb +++ b/src/ghdldrv/ghdllocal.adb @@ -1065,6 +1065,62 @@ package body Ghdllocal is Disp_Vhdl.Disp_Vhdl (Std_Package.Std_Standard_Unit); end Perform_Action; + -- Command --find-top. + type Command_Find_Top is new Command_Lib with null record; + function Decode_Command (Cmd : Command_Find_Top; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Find_Top) return String; + procedure Perform_Action (Cmd : in out Command_Find_Top; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Find_Top; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--find-top"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Find_Top) return String + is + pragma Unreferenced (Cmd); + begin + return "--find-top Disp possible top entity in work library"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Find_Top; + Args : Argument_List) + is + use Libraries; + pragma Unreferenced (Cmd); + From : Iir; + Top : Iir; + begin + Setup_Libraries (True); + + if Args'Length = 0 then + From := Work_Library; + elsif Args'Length = 1 then + From := Find_Design_File + (Work_Library, Name_Table.Get_Identifier (Args (Args'First).all)); + if not Is_Valid (From) then + Error ("cannot find '" & Args (Args'First).all & "' in library"); + raise Option_Error; + end if; + else + Error ("command '--find-top' accepts at most one argument"); + raise Option_Error; + end if; + + Top := Configuration.Find_Top_Entity (From); + + if Top = Null_Iir then + Error ("no top entity found"); + else + Put_Line (Name_Table.Image (Get_Identifier (Top))); + end if; + end Perform_Action; + -- Command --bug-box. type Command_Bug_Box is new Command_Type with null record; function Decode_Command (Cmd : Command_Bug_Box; Name : String) @@ -1539,6 +1595,7 @@ package body Ghdllocal is Register_Command (new Command_Remove); Register_Command (new Command_Copy); Register_Command (new Command_Disp_Standard); + Register_Command (new Command_Find_Top); Register_Command (new Command_Bug_Box); end Register_Commands; end Ghdllocal; diff --git a/src/libraries.adb b/src/libraries.adb index 01bf46faf..864543b36 100644 --- a/src/libraries.adb +++ b/src/libraries.adb @@ -1482,6 +1482,21 @@ package body Libraries is end case; end Find_Design_Unit; + function Find_Design_File (Lib : Iir_Library_Declaration; Name : Name_Id) + return Iir + is + File : Iir; + begin + File := Get_Design_File_Chain (Lib); + while Is_Valid (File) loop + if Get_Design_File_Filename (File) = Name then + return File; + end if; + File := Get_Chain (File); + end loop; + return Null_Iir; + end Find_Design_File; + function Is_Obsolete (Design_Unit : Iir_Design_Unit; Loc : Iir) return Boolean is diff --git a/src/libraries.ads b/src/libraries.ads index 2d1483833..edaf74292 100644 --- a/src/libraries.ads +++ b/src/libraries.ads @@ -187,6 +187,12 @@ package Libraries is -- Return null_iir if the design unit is not found. function Find_Design_Unit (Unit : Iir) return Iir_Design_Unit; + -- Search design file NAME in library LIB. This is not very efficient as + -- this is a simple linear search. NAME must correspond exactely to the + -- design file name. + function Find_Design_File (Lib : Iir_Library_Declaration; Name : Name_Id) + return Iir; + -- Find an entity whose name is NAME in any library. -- If there is no such entity, return NULL_IIR. -- If there are severals entities, return NULL_IIR; diff --git a/src/vhdl/configuration.adb b/src/vhdl/configuration.adb index 2c0e2dd38..a0fc0bb7a 100644 --- a/src/vhdl/configuration.adb +++ b/src/vhdl/configuration.adb @@ -15,12 +15,15 @@ -- 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 Libraries; with Errorout; use Errorout; with Std_Package; with Name_Table; use Name_Table; with Flags; with Iirs_Utils; use Iirs_Utils; +with Iirs_Walk; +with Sem_Scopes; with Canon; package body Configuration is @@ -755,4 +758,199 @@ package body Configuration is 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 Iirs_Walk; + + function Add_Entity_Cb (Design : Iir) return Walk_Status + is + Kind : constant Iir_Kind := Get_Kind (Get_Library_Unit (Design)); + begin + if Get_Date (Design) < Date_Analyzed then + return Walk_Continue; + end if; + + case Iir_Kinds_Library_Unit_Declaration (Kind) is + when Iir_Kind_Architecture_Body + | Iir_Kind_Configuration_Declaration => + Libraries.Load_Design_Unit (Design, Null_Iir); + when Iir_Kind_Entity_Declaration => + Libraries.Load_Design_Unit (Design, Null_Iir); + Sem_Scopes.Add_Name (Get_Library_Unit (Design)); + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Package_Body + | 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); + Set_Elab_Flag (Get_Parent (Unit), True); + 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 Sem_Scopes; + Comp : constant Iir := Get_Named_Entity (Inst); + Interp : constant Name_Interpretation_Type := + Get_Interpretation (Get_Identifier (Comp)); + Decl : Iir; + begin + 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 Get_Date (Design) < Date_Analyzed then + return Walk_Continue; + end if; + + case Iir_Kinds_Library_Unit_Declaration (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 => + -- TODO + raise Program_Error; + -- Mark_Units_Of_Block_Configuration + -- (Get_Block_Configuration (Unit)); + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Package_Body + | Iir_Kind_Entity_Declaration + | 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. + Sem_Scopes.Push_Interpretations; + 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); + + Sem_Scopes.Close_Declarative_Region; + 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 + Set_Elab_Flag (Design, False); + else + 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 + 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; + end Configuration; diff --git a/src/vhdl/configuration.ads b/src/vhdl/configuration.ads index ddd6206d4..6ec910f00 100644 --- a/src/vhdl/configuration.ads +++ b/src/vhdl/configuration.ads @@ -55,4 +55,9 @@ package Configuration is -- ENTITY has no ports or all ports type are constrained. -- If not, emit a elab error message. procedure Check_Entity_Declaration_Top (Entity : Iir_Entity_Declaration); + + -- Use heuritics to find the top entity in FROM (either a library or + -- a design file): mark all instantiated units and return the unmarked + -- one if there is only one. + function Find_Top_Entity (From : Iir) return Iir; end Configuration; diff --git a/src/vhdl/iirs_walk.adb b/src/vhdl/iirs_walk.adb index 80f825f68..3bc4ecf07 100644 --- a/src/vhdl/iirs_walk.adb +++ b/src/vhdl/iirs_walk.adb @@ -17,6 +17,7 @@ -- 02111-1307, USA. with Iirs_Utils; use Iirs_Utils; +with Errorout; use Errorout; package body Iirs_Walk is function Walk_Chain (Chain : Iir; Cb : Walk_Cb) return Walk_Status @@ -118,4 +119,59 @@ package body Iirs_Walk is end case; return Status; end Walk_Assignment_Target; + + function Walk_Design_Units (Parent : Iir; Cb : Walk_Cb) return Walk_Status + is + El : Iir; + Status : Walk_Status := Walk_Continue; + begin + case Get_Kind (Parent) is + when Iir_Kind_Library_Declaration => + El := Get_Design_File_Chain (Parent); + while Is_Valid (El) loop + Status := Walk_Design_Units (El, Cb); + exit when Status /= Walk_Continue; + El := Get_Chain (El); + end loop; + return Status; + when Iir_Kind_Design_File => + El := Get_First_Design_Unit (Parent); + while Is_Valid (El) loop + Status := Cb.all (El); + exit when Status /= Walk_Continue; + El := Get_Chain (El); + end loop; + return Status; + when others => + Error_Kind ("walk_library_units", Parent); + end case; + end Walk_Design_Units; + + function Walk_Concurrent_Statements_Chain (Chain : Iir; Cb : Walk_Cb) + return Walk_Status + is + Status : Walk_Status; + El : Iir; + begin + El := Chain; + while Is_Valid (El) loop + case Iir_Kinds_Concurrent_Statement (Get_Kind (El)) is + when Iir_Kinds_Simple_Concurrent_Statement + | Iir_Kind_Component_Instantiation_Statement => + return Cb.all (El); + when Iir_Kind_Block_Statement => + Status := Cb.all (El); + if Status /= Walk_Continue then + return Status; + end if; + return Walk_Concurrent_Statements_Chain + (Get_Concurrent_Statement_Chain (El), Cb); + when others => + Error_Kind ("walk_concurrent_statements_chain", El); + end case; + El := Get_Chain (El); + end loop; + + return Walk_Continue; + end Walk_Concurrent_Statements_Chain; end Iirs_Walk; diff --git a/src/vhdl/iirs_walk.ads b/src/vhdl/iirs_walk.ads index 4c098f7d5..c00aa955d 100644 --- a/src/vhdl/iirs_walk.ads +++ b/src/vhdl/iirs_walk.ads @@ -42,4 +42,12 @@ package Iirs_Walk is -- Walk on all stmts and sub-stmts of CHAIN. function Walk_Sequential_Stmt_Chain (Chain : Iir; Cb : Walk_Cb) return Walk_Status; + + -- Walk on all design units of library or design file PARENT. + function Walk_Design_Units (Parent : Iir; Cb : Walk_Cb) return Walk_Status; + + -- Walk on all concurrent statements (and sub statements) of CHAIN. + function Walk_Concurrent_Statements_Chain (Chain : Iir; Cb : Walk_Cb) + return Walk_Status; + end Iirs_Walk; |