path: root/src/vhdl/translate/trans-chap12.adb

--  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 := Strip_Denoting_Name
        (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;