xen/arch/x86/domctl.c

--  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
                     Error_Msg_Elab (Bod, "%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;

   --  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;
   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);
            Report_Start_Group;
            Warning_Msg_Elab (Warnid_Binding, Conf,
                              "instance %i of component %i is not bound",
                              (+Inst, +Get_Instantiated_Unit (Inst)));
            Warning_Msg_Elab (Warnid_Binding, Current_Configuration,
                              "(in %n)", +Current_Configuration);
            Report_End_Group;
         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 : 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 not Flags.Flag_Elaborate_With_Outdated then
            if Get_Date (Design) < Date_Analyzed then
               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 =>
               --  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_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
      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;

   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
               declare
                  use Str_Table;
                  Str8 : String8_Id;
                  Ntype : Iir;
               begin
                  Str8 := Create_String8;
                  Append_String8_String (Value.all);
                  Res := Create_Iir (Iir_Kind_String_Literal8);
                  Set_String8_Id (Res, Str8);
                  --  FIXME: check characters are in the type.
                  Set_String_Length (Res, Value'Length);
                  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);
               end;
            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;
	Commit message (Expand)	Author	Age	Files	Lines
*	Move iommu code to arch-generic locations, and also clean up some VT-d code.	Keir Fraser	2008-03-17	1	-1/+1
*	amd iommu: Allow device deassignment.	Keir Fraser	2008-02-18	1	-1/+1
*	Enable HVM guest VT-d device hotplug via a simple ACPI hotplug device model.	Keir Fraser	2008-02-15	1	-0/+45
*	x86 iommu: Define vendor-neutral interface for access to IOMMU.	Keir Fraser	2008-02-14	1	-4/+4
*	Fix build after I removed test_assign_device from domctl union.	Keir Fraser	2007-12-12	1	-2/+2
*	vt-d: Test device assignability in xend, but defer actual assignment to qemu-dm.	Keir Fraser	2007-12-12	1	-3/+23
*	vt-d: Print messages when:	Keir Fraser	2007-12-04	1	-0/+5
*	domctl: Fix handling of size parameter in ext_vcpucontext domctl commands.	Keir Fraser	2007-11-28	1	-7/+6
*	x86: emulate I/O port access breakpoints	Keir Fraser	2007-11-22	1	-0/+8
*	vt-d: Free memory of g2m_ioport_list.	Keir Fraser	2007-11-06	1	-21/+25
*	x86: Remove dead code from arch_get_info_guest().	Keir Fraser	2007-10-29	1	-18/+5
*	x86: Save/restore new syscall/sysenter context info.	Keir Fraser	2007-10-25	1	-1/+73
*	hvm, vt-d: Add memory cache-attribute pinning domctl for HVM	Keir Fraser	2007-10-23	1	-0/+19
*	x86, vt-d: Fail PCI device assignment if device already assigned.	Keir Fraser	2007-10-18	1	-2/+6
*	domctl and p2m changes for PCI passthru.	Keir Fraser	2007-09-20	1	-0/+151
*	hvm: Always keep canonical copy of RIP/RSP/RFLAGS in	kfraser@localhost.localdomain	2007-09-19	1	-6/+0
*	hvm: hvm_{load,store}_cpu_guest_regs() does not touch segment	kfraser@localhost.localdomain	2007-09-19	1	-5/+14
*	hvm: Remove hvm-specific NMI flag and use generic flag instead.	kfraser@localhost.localdomain	2007-09-06	1	-5/+1
*	Implement x86 continuable domain destroy.	kfraser@localhost.localdomain	2007-08-31	1	-3/+7
*	Xen Security Modules: XSM	kfraser@localhost.localdomain	2007-08-31	1	-0/+56
*	Implement domctl_sendtrigger_nmi for x86 hvm.	kfraser@localhost.localdomain	2007-07-13	1	-0/+40
*	hvm: e820 public header cleanup.	Keir Fraser	2007-06-10	1	-1/+0
*	hvm: Pause domain during state save/load.	kfraser@localhost.localdomain	2007-05-31	1	-0/+4
*	xen: More 'IS_COMPAT' cleanups.	kfraser@localhost.localdomain	2007-04-27	1	-4/+4
*	xen: Rename remaining vcpu_flags as pause_flags.	kfraser@localhost.localdomain	2007-03-29	1	-1/+1
*	xen: Get rid of some VCPUF_* flags and move into their own byte fields.	kfraser@localhost.localdomain	2007-03-29	1	-1/+1
*	xen: Set VGCF_online flag appropriately for getvcpucontext.	kfraser@localhost.localdomain	2007-03-12	1	-0/+2
*	xen/x86: add allocation success checks.	kfraser@localhost.localdomain	2007-03-09	1	-2/+8
*	x86/64: Save/restore user pagetable pointer for x86/64 PV guests.	Keir Fraser	2007-03-02	1	-0/+7
*	xen: Use RCU-based domain-locking functions where appropriate.	kfraser@localhost.localdomain	2007-03-01	1	-22/+22
*	hvm: Fix getvcpucontext to return the correct CR3 value.	kfraser@localhost.localdomain	2007-02-20	1	-14/+16
*	Another domctl fix to insert missing copy_to_guest.	kfraser@localhost.localdomain	2007-02-14	1	-0/+3
*	Add missing breaks to {set,get}_address_size domctls.	kfraser@localhost.localdomain	2007-02-14	1	-0/+2
*	[XEN] New paging-assistance interface.	Tim Deegan	2007-02-14	1	-2/+2
*	[HVM] Save/restore: dynamically calculate the size of the save buffer	Tim Deegan	2007-02-07	1	-5/+20
*	[HVM] Save/restore: clean up the new hypercall interface	Tim Deegan	2007-01-31	1	-30/+32
*	[HVM] Save/restore: clean up marshalling code	Tim Deegan	2007-01-31	1	-0/+3
*	[HVM] Save/restore cleanups: don't save state for downed vcpus.	Tim Deegan	2007-01-29	1	-11/+9
*	Rename find_domain_by_id() to get_domain_by_id().	kaf24@localhost.localdomain	2007-01-26	1	-10/+10
*	Don't clobber vcpu flags when getting vcpu context.	kaf24@localhost.localdomain	2007-01-26	1	-5/+3
*	Fix 32-bit build.	kaf24@localhost.localdomain	2007-01-26	1	-0/+1
*	32-on-64: New set_address_size domctl for switching to compat mode.	kaf24@localhost.localdomain	2007-01-26	1	-0/+40
*	Make domctl/sysctl interfaces 32-/64-bit invariant.	kfraser@localhost.localdomain	2007-01-24	1	-44/+20
*	[HVM] fix save/restore on 64b HV	kfraser@localhost.localdomain	2007-01-23	1	-4/+12
*	[XEN] Move hvm get/set domctl() commands to arch/x86/domctl.c.	kfraser@localhost.localdomain	2007-01-19	1	-0/+73
*	Support for save and restore of compatibility guests	Emmanuel Ackaouy	2007-01-05	1	-1/+4
*	Enable compatibility mode operation for HYPERVISOR_domctl. Also add logic	Emmanuel Ackaouy	2007-01-05	1	-27/+70
*	Add page table setup and handling, including the creation of an m2p table	Emmanuel Ackaouy	2007-01-05	1	-1/+6
*	[XEN] Remove VGCF_hvm_guest, replace with XEN_DOMINF_hvm_guest.	kfraser@localhost.localdomain	2006-11-03	1	-2/+0
*	[XEN] Fix x86/64 build.	kfraser@localhost.localdomain	2006-11-01	1	-1/+1