-- Iir to ortho translator. -- 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. with System; with Configuration; with Interfaces.C_Streams; with Ada.Text_IO; with Errorout; use Errorout; with Std_Package; use Std_Package; with Iirs_Utils; use Iirs_Utils; with Name_Table; with Libraries; with Flags; with Sem; with Trans.Chap1; with Trans.Chap2; with Trans.Chap6; with Trans.Rtis; with Trans.Helpers2; use Trans.Helpers2; with Translation; use Translation; with Trans_Decls; use Trans_Decls; package body Trans.Chap12 is -- Create __ghdl_ELABORATE procedure Gen_Main (Entity : Iir_Entity_Declaration; Arch : Iir_Architecture_Body; Config_Subprg : O_Dnode; Nbr_Pkgs : Natural) is Entity_Info : Block_Info_Acc; Arch_Info : Block_Info_Acc; Inter_List : O_Inter_List; Assoc : O_Assoc_List; Instance : O_Dnode; Arch_Instance : O_Dnode; Mark : Id_Mark_Type; Arr_Type : O_Tnode; Arr : O_Dnode; begin Arch_Info := Get_Info (Arch); Entity_Info := Get_Info (Entity); -- We need to create code. Set_Global_Storage (O_Storage_Private); -- Create the array of RTIs for packages (as a variable, initialized -- during elaboration). Arr_Type := New_Constrained_Array_Type (Rtis.Ghdl_Rti_Array, New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Pkgs))); New_Var_Decl (Arr, Get_Identifier ("__ghdl_top_RTIARRAY"), O_Storage_Private, Arr_Type); -- The elaboration entry point. Start_Procedure_Decl (Inter_List, Get_Identifier ("__ghdl_ELABORATE"), O_Storage_Public); Finish_Subprogram_Decl (Inter_List, Ghdl_Elaborate); Start_Subprogram_Body (Ghdl_Elaborate); New_Var_Decl (Arch_Instance, Wki_Arch_Instance, O_Storage_Local, Arch_Info.Block_Decls_Ptr_Type); New_Var_Decl (Instance, Wki_Instance, O_Storage_Local, Entity_Info.Block_Decls_Ptr_Type); -- Create instance for the architecture. New_Assign_Stmt (New_Obj (Arch_Instance), Gen_Alloc (Alloc_System, New_Lit (Get_Scope_Size (Arch_Info.Block_Scope)), Arch_Info.Block_Decls_Ptr_Type)); -- Set the top instance. New_Assign_Stmt (New_Obj (Instance), New_Address (New_Selected_Acc_Value (New_Obj (Arch_Instance), Arch_Info.Block_Parent_Field), Entity_Info.Block_Decls_Ptr_Type)); -- Clear parent field of entity link. New_Assign_Stmt (New_Selected_Element (New_Selected_Acc_Value (New_Obj (Instance), Entity_Info.Block_Link_Field), Rtis.Ghdl_Entity_Link_Parent), New_Lit (New_Null_Access (Rtis.Ghdl_Component_Link_Acc))); -- Set top instances and RTI. -- Do it before the elaboration code, since it may be used to -- diagnose errors. -- Call ghdl_rti_add_top Start_Association (Assoc, Ghdl_Rti_Add_Top); New_Association (Assoc, New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Pkgs)))); New_Association (Assoc, New_Lit (New_Global_Address (Arr, Rtis.Ghdl_Rti_Arr_Acc))); New_Association (Assoc, New_Lit (Rtis.New_Rti_Address (Get_Info (Arch).Block_Rti_Const))); New_Association (Assoc, New_Convert_Ov (New_Obj_Value (Arch_Instance), Ghdl_Ptr_Type)); New_Procedure_Call (Assoc); -- Add std.standard rti Start_Association (Assoc, Ghdl_Rti_Add_Package); New_Association (Assoc, New_Lit (Rtis.New_Rti_Address (Get_Info (Standard_Package).Package_Rti_Const))); New_Procedure_Call (Assoc); Gen_Filename (Get_Design_File (Get_Design_Unit (Entity))); -- Elab package dependences of top entity (so that default -- expressions can be evaluated). Start_Association (Assoc, Entity_Info.Block_Elab_Pkg_Subprg); New_Procedure_Call (Assoc); -- init instance Set_Scope_Via_Param_Ptr (Entity_Info.Block_Scope, Instance); Push_Identifier_Prefix (Mark, ""); Chap1.Translate_Entity_Init (Entity); -- elab instance Start_Association (Assoc, Arch_Info.Block_Elab_Subprg); New_Association (Assoc, New_Obj_Value (Instance)); New_Procedure_Call (Assoc); --Chap6.Link_Instance_Name (Null_Iir, Entity); -- configure instance. Start_Association (Assoc, Config_Subprg); New_Association (Assoc, New_Obj_Value (Arch_Instance)); New_Procedure_Call (Assoc); Pop_Identifier_Prefix (Mark); Clear_Scope (Entity_Info.Block_Scope); Finish_Subprogram_Body; Current_Filename_Node := O_Dnode_Null; end Gen_Main; procedure Gen_Setup_Info is Cst : O_Dnode; pragma Unreferenced (Cst); begin Cst := Create_String (Flags.Flag_String, Get_Identifier ("__ghdl_flag_string"), O_Storage_Public); end Gen_Setup_Info; procedure Gen_Last_Arch (Entity : Iir_Entity_Declaration) is Entity_Info : Block_Info_Acc; Arch : Iir_Architecture_Body; Arch_Info : Block_Info_Acc; Lib : Iir_Library_Declaration; Lib_Mark, Entity_Mark, Arch_Mark : Id_Mark_Type; Config : Iir_Configuration_Declaration; Config_Info : Config_Info_Acc; Const : O_Dnode; Instance : O_Dnode; Inter_List : O_Inter_List; Constr : O_Assoc_List; Subprg : O_Dnode; begin Arch := Libraries.Get_Latest_Architecture (Entity); if Arch = Null_Iir then Error_Msg_Elab ("no architecture for " & Disp_Node (Entity)); end if; Arch_Info := Get_Info (Arch); if Arch_Info = null then -- Nothing to do here, since the architecture is not used. return; end if; Entity_Info := Get_Info (Entity); -- Create trampoline for elab, default_architecture -- re-create instsize. Reset_Identifier_Prefix; Lib := Get_Library (Get_Design_File (Get_Design_Unit (Entity))); Push_Identifier_Prefix (Lib_Mark, Get_Identifier (Lib)); Push_Identifier_Prefix (Entity_Mark, Get_Identifier (Entity)); Push_Identifier_Prefix (Arch_Mark, "LASTARCH"); -- Instance size. New_Const_Decl (Const, Create_Identifier ("INSTSIZE"), O_Storage_Public, Ghdl_Index_Type); Start_Const_Value (Const); Finish_Const_Value (Const, Get_Scope_Size (Arch_Info.Block_Scope)); -- Elaborator. Start_Procedure_Decl (Inter_List, Create_Identifier ("ELAB"), O_Storage_Public); New_Interface_Decl (Inter_List, Instance, Wki_Instance, Entity_Info.Block_Decls_Ptr_Type); Finish_Subprogram_Decl (Inter_List, Subprg); Start_Subprogram_Body (Subprg); Start_Association (Constr, Arch_Info.Block_Elab_Subprg); New_Association (Constr, New_Obj_Value (Instance)); New_Procedure_Call (Constr); Finish_Subprogram_Body; -- Default config. Config := Get_Library_Unit (Get_Default_Configuration_Declaration (Arch)); Config_Info := Get_Info (Config); if Config_Info /= null then -- Do not create a trampoline for the default_config if it is not -- used. Start_Procedure_Decl (Inter_List, Create_Identifier ("DEFAULT_CONFIG"), O_Storage_Public); New_Interface_Decl (Inter_List, Instance, Wki_Instance, Arch_Info.Block_Decls_Ptr_Type); Finish_Subprogram_Decl (Inter_List, Subprg); Start_Subprogram_Body (Subprg); Start_Association (Constr, Config_Info.Config_Subprg); New_Association (Constr, New_Obj_Value (Instance)); New_Procedure_Call (Constr); Finish_Subprogram_Body; end if; Pop_Identifier_Prefix (Arch_Mark); Pop_Identifier_Prefix (Entity_Mark); Pop_Identifier_Prefix (Lib_Mark); end Gen_Last_Arch; procedure Gen_Dummy_Default_Config (Arch : Iir_Architecture_Body) is Entity : Iir_Entity_Declaration; Lib : Iir_Library_Declaration; Lib_Mark, Entity_Mark, Sep_Mark, Arch_Mark : Id_Mark_Type; Inter_List : O_Inter_List; Subprg : O_Dnode; begin Reset_Identifier_Prefix; Entity := Get_Entity (Arch); Lib := Get_Library (Get_Design_File (Get_Design_Unit (Arch))); Push_Identifier_Prefix (Lib_Mark, Get_Identifier (Lib)); Push_Identifier_Prefix (Entity_Mark, Get_Identifier (Entity)); Push_Identifier_Prefix (Sep_Mark, "ARCH"); Push_Identifier_Prefix (Arch_Mark, Get_Identifier (Arch)); -- Elaborator. Start_Procedure_Decl (Inter_List, Create_Identifier ("DEFAULT_CONFIG"), O_Storage_Public); Finish_Subprogram_Decl (Inter_List, Subprg); Start_Subprogram_Body (Subprg); Chap6.Gen_Program_Error (Arch, Chap6.Prg_Err_Dummy_Config); Finish_Subprogram_Body; Pop_Identifier_Prefix (Arch_Mark); Pop_Identifier_Prefix (Sep_Mark); Pop_Identifier_Prefix (Entity_Mark); Pop_Identifier_Prefix (Lib_Mark); end Gen_Dummy_Default_Config; procedure Gen_Dummy_Package_Declaration (Unit : Iir_Design_Unit) is Pkg : Iir_Package_Declaration; Lib : Iir_Library_Declaration; Lib_Mark, Pkg_Mark : Id_Mark_Type; Decl : Iir; begin Libraries.Load_Design_Unit (Unit, Null_Iir); Pkg := Get_Library_Unit (Unit); Reset_Identifier_Prefix; Lib := Get_Library (Get_Design_File (Get_Design_Unit (Pkg))); Push_Identifier_Prefix (Lib_Mark, Get_Identifier (Lib)); Push_Identifier_Prefix (Pkg_Mark, Get_Identifier (Pkg)); if Get_Need_Body (Pkg) then Decl := Get_Declaration_Chain (Pkg); while Decl /= Null_Iir loop case Get_Kind (Decl) is when Iir_Kind_Function_Declaration | Iir_Kind_Procedure_Declaration => -- Generate empty body. -- Never a second spec, as this is within a package -- declaration. pragma Assert (not Is_Second_Subprogram_Specification (Decl)); if not Get_Foreign_Flag (Decl) then declare Mark : Id_Mark_Type; Inter_List : O_Inter_List; Proc : O_Dnode; begin Chap2.Push_Subprg_Identifier (Decl, Mark); Start_Procedure_Decl (Inter_List, Create_Identifier, O_Storage_Public); Finish_Subprogram_Decl (Inter_List, Proc); Start_Subprogram_Body (Proc); Finish_Subprogram_Body; Pop_Identifier_Prefix (Mark); end; end if; when others => null; end case; Decl := Get_Chain (Decl); end loop; end if; -- Create the body elaborator. declare Inter_List : O_Inter_List; Proc : O_Dnode; begin Start_Procedure_Decl (Inter_List, Create_Identifier ("ELAB_BODY"), O_Storage_Public); Finish_Subprogram_Decl (Inter_List, Proc); Start_Subprogram_Body (Proc); Finish_Subprogram_Body; end; Pop_Identifier_Prefix (Pkg_Mark); Pop_Identifier_Prefix (Lib_Mark); end Gen_Dummy_Package_Declaration; procedure Write_File_List (Filelist : String) is use Interfaces.C_Streams; use System; use Configuration; use Name_Table; -- Add all dependences of UNIT. -- UNIT is not used, but added during link. procedure Add_Unit_Dependences (Unit : Iir_Design_Unit) is Dep_List : Iir_List; Dep : Iir; Dep_Unit : Iir_Design_Unit; Lib_Unit : Iir; begin -- Load the unit in memory to compute the dependence list. Libraries.Load_Design_Unit (Unit, Null_Iir); Update_Node_Infos; Set_Elab_Flag (Unit, True); Design_Units.Append (Unit); if Flag_Rti then Rtis.Generate_Library (Get_Library (Get_Design_File (Unit)), True); end if; Lib_Unit := Get_Library_Unit (Unit); case Get_Kind (Lib_Unit) is when Iir_Kind_Package_Declaration => -- The body may be required due to incomplete constant -- declarations, or to call to a subprogram. declare Pack_Body : Iir; begin Pack_Body := Libraries.Find_Secondary_Unit (Unit, Null_Identifier); if Pack_Body /= Null_Iir then Add_Unit_Dependences (Pack_Body); else Gen_Dummy_Package_Declaration (Unit); end if; end; when Iir_Kind_Architecture_Body => Gen_Dummy_Default_Config (Lib_Unit); when others => null; end case; Dep_List := Get_Dependence_List (Unit); for I in Natural loop Dep := Get_Nth_Element (Dep_List, I); exit when Dep = Null_Iir; Dep_Unit := Libraries.Find_Design_Unit (Dep); if Dep_Unit = Null_Iir then Error_Msg_Elab ("could not find design unit " & Disp_Node (Dep)); elsif not Get_Elab_Flag (Dep_Unit) then Add_Unit_Dependences (Dep_Unit); end if; end loop; end Add_Unit_Dependences; -- Add not yet added units of FILE. procedure Add_File_Units (File : Iir_Design_File) is Unit : Iir_Design_Unit; begin Unit := Get_First_Design_Unit (File); while Unit /= Null_Iir loop if not Get_Elab_Flag (Unit) then -- Unit not used. Add_Unit_Dependences (Unit); end if; Unit := Get_Chain (Unit); end loop; end Add_File_Units; Nul : constant Character := Character'Val (0); Fname : String := Filelist & Nul; Mode : constant String := "wt" & Nul; F : FILEs; R : int; S : size_t; pragma Unreferenced (R, S); -- FIXME Id : Name_Id; Lib : Iir_Library_Declaration; File : Iir_Design_File; Unit : Iir_Design_Unit; J : Natural; begin F := fopen (Fname'Address, Mode'Address); if F = NULL_Stream then Error_Msg_Elab ("cannot open " & Filelist); end if; -- Set elab flags on units, and remove it on design files. for I in Design_Units.First .. Design_Units.Last loop Unit := Design_Units.Table (I); Set_Elab_Flag (Unit, True); File := Get_Design_File (Unit); Set_Elab_Flag (File, False); end loop; J := Design_Units.First; while J <= Design_Units.Last loop Unit := Design_Units.Table (J); File := Get_Design_File (Unit); if not Get_Elab_Flag (File) then Set_Elab_Flag (File, True); -- Add dependences of unused design units, otherwise the object -- link case failed. Add_File_Units (File); Lib := Get_Library (File); R := fputc (Character'Pos ('>'), F); Id := Get_Library_Directory (Lib); S := fwrite (Get_Address (Id), size_t (Get_Name_Length (Id)), 1, F); R := fputc (10, F); Id := Get_Design_File_Filename (File); S := fwrite (Get_Address (Id), size_t (Get_Name_Length (Id)), 1, F); R := fputc (10, F); end if; J := J + 1; end loop; end Write_File_List; procedure Elaborate (Primary : String; Secondary : String; Filelist : String; Whole : Boolean) is use Name_Table; use Configuration; Primary_Id : Name_Id; Secondary_Id : Name_Id; Unit : Iir_Design_Unit; Lib_Unit : Iir; Config : Iir_Design_Unit; Config_Lib : Iir_Configuration_Declaration; Entity : Iir_Entity_Declaration; Arch : Iir_Architecture_Body; Conf_Info : Config_Info_Acc; Last_Design_Unit : Natural; Nbr_Pkgs : Natural; begin Primary_Id := Get_Identifier (Primary); if Secondary /= "" then Secondary_Id := Get_Identifier (Secondary); else Secondary_Id := Null_Identifier; end if; Config := Configure (Primary_Id, Secondary_Id); if Config = Null_Iir then return; end if; Config_Lib := Get_Library_Unit (Config); Entity := Get_Entity (Config_Lib); Arch := Get_Block_Specification (Get_Block_Configuration (Config_Lib)); -- Be sure the entity can be at the top of a design. Check_Entity_Declaration_Top (Entity); -- If all design units are loaded, late semantic checks can be -- performed. if Flag_Load_All_Design_Units then for I in Design_Units.First .. Design_Units.Last loop Unit := Design_Units.Table (I); Sem.Sem_Analysis_Checks_List (Unit, False); -- There cannot be remaining checks to do. pragma Assert (Get_Analysis_Checks_List (Unit) = Null_Iir_List); end loop; end if; -- Return now in case of errors. if Nbr_Errors /= 0 then return; end if; if Flags.Verbose then Ada.Text_IO.Put_Line ("List of units in the hierarchy design:"); for I in Design_Units.First .. Design_Units.Last loop Unit := Design_Units.Table (I); Lib_Unit := Get_Library_Unit (Unit); Ada.Text_IO.Put_Line (' ' & Disp_Node (Lib_Unit)); end loop; end if; if Whole then -- In compile-and-elaborate mode, do not generate code for -- unused subprograms. -- FIXME: should be improved by creating a span-tree. Flag_Discard_Unused := True; Flag_Discard_Unused_Implicit := True; end if; -- Generate_Library add infos, therefore the info array must be -- adjusted. Update_Node_Infos; Rtis.Generate_Library (Libraries.Std_Library, True); Translate_Standard (Whole); -- Translate all configurations needed. -- Also, set the ELAB_FLAG on package with body. for I in Design_Units.First .. Design_Units.Last loop Unit := Design_Units.Table (I); Lib_Unit := Get_Library_Unit (Unit); if Whole then -- In whole compilation mode, force to generate RTIS of -- libraries. Rtis.Generate_Library (Get_Library (Get_Design_File (Unit)), True); end if; case Get_Kind (Lib_Unit) is when Iir_Kind_Configuration_Declaration => -- Always generate code for configuration. -- Because default binding may be changed between analysis -- and elaboration. Translate (Unit, True); when Iir_Kind_Entity_Declaration | Iir_Kind_Architecture_Body | Iir_Kind_Package_Declaration | Iir_Kind_Package_Instantiation_Declaration => -- For package spec, mark it as 'body is not present', this -- flag will be set below when the body is translated. Set_Elab_Flag (Unit, False); Translate (Unit, Whole); when Iir_Kind_Package_Body => -- Mark the spec with 'body is present' flag. Set_Elab_Flag (Get_Design_Unit (Get_Package (Lib_Unit)), True); Translate (Unit, Whole); when others => Error_Kind ("elaborate", Lib_Unit); end case; end loop; -- Generate code to elaboration body-less package. -- -- When a package is analyzed, we don't know wether there is body -- or not. Therefore, we assume there is always a body, and will -- elaborate the body (which elaborates its spec). If a package -- has no body, create the body elaboration procedure. for I in Design_Units.First .. Design_Units.Last loop Unit := Design_Units.Table (I); Lib_Unit := Get_Library_Unit (Unit); case Get_Kind (Lib_Unit) is when Iir_Kind_Package_Declaration => if not Get_Elab_Flag (Unit) then Chap2.Elab_Package_Body (Lib_Unit, Null_Iir); end if; when Iir_Kind_Entity_Declaration => Gen_Last_Arch (Lib_Unit); when Iir_Kind_Architecture_Body | Iir_Kind_Package_Body | Iir_Kind_Configuration_Declaration | Iir_Kind_Package_Instantiation_Declaration => null; when others => Error_Kind ("elaborate(2)", Lib_Unit); end case; end loop; Rtis.Generate_Top (Nbr_Pkgs); -- Create main code. Conf_Info := Get_Info (Config_Lib); Gen_Main (Entity, Arch, Conf_Info.Config_Subprg, Nbr_Pkgs); Gen_Setup_Info; -- Index of the last design unit, required by the design. Last_Design_Unit := Design_Units.Last; -- Disp list of files needed. -- FIXME: extract the link completion part of WRITE_FILE_LIST. if Filelist /= "" then Write_File_List (Filelist); end if; if Flags.Verbose then Ada.Text_IO.Put_Line ("List of units not used:"); for I in Last_Design_Unit + 1 .. Design_Units.Last loop Unit := Design_Units.Table (I); Lib_Unit := Get_Library_Unit (Unit); Ada.Text_IO.Put_Line (' ' & Disp_Node (Lib_Unit)); end loop; end if; end Elaborate; end Trans.Chap12;