-- 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 Name_Table; with Std_Names; with Std_Package; use Std_Package; with Errorout; use Errorout; with Sem_Inst; with Nodes_Meta; with Iirs_Utils; use Iirs_Utils; with Trans.Chap3; with Trans.Chap4; with Trans.Chap5; with Trans.Chap6; with Trans.Chap8; with Trans.Rtis; with Trans_Decls; use Trans_Decls; with Translation; use Translation; package body Trans.Chap2 is use Trans.Subprgs; use Trans.Helpers; procedure Elab_Package (Spec : Iir_Package_Declaration); type Name_String_Xlat_Array is array (Name_Id range <>) of String (1 .. 4); Operator_String_Xlat : constant Name_String_Xlat_Array (Std_Names.Name_Id_Operators) := (Std_Names.Name_Op_Equality => "OPEq", Std_Names.Name_Op_Inequality => "OPNe", Std_Names.Name_Op_Less => "OPLt", Std_Names.Name_Op_Less_Equal => "OPLe", Std_Names.Name_Op_Greater => "OPGt", Std_Names.Name_Op_Greater_Equal => "OPGe", Std_Names.Name_Op_Plus => "OPPl", Std_Names.Name_Op_Minus => "OPMi", Std_Names.Name_Op_Mul => "OPMu", Std_Names.Name_Op_Div => "OPDi", Std_Names.Name_Op_Exp => "OPEx", Std_Names.Name_Op_Concatenation => "OPCc", Std_Names.Name_Op_Condition => "OPCd", Std_Names.Name_Op_Match_Equality => "OPQe", Std_Names.Name_Op_Match_Inequality => "OPQi", Std_Names.Name_Op_Match_Less => "OPQL", Std_Names.Name_Op_Match_Less_Equal => "OPQl", Std_Names.Name_Op_Match_Greater => "OPQG", Std_Names.Name_Op_Match_Greater_Equal => "OPQg"); -- Set the identifier prefix with the subprogram identifier and -- overload number if any. procedure Push_Subprg_Identifier (Spec : Iir; Mark : out Id_Mark_Type) is Id : Name_Id; begin -- FIXME: name_shift_operators, name_logical_operators, -- name_word_operators, name_mod, name_rem Id := Get_Identifier (Spec); if Id in Std_Names.Name_Id_Operators then Push_Identifier_Prefix (Mark, Operator_String_Xlat (Id), Get_Overload_Number (Spec)); else Push_Identifier_Prefix (Mark, Id, Get_Overload_Number (Spec)); end if; end Push_Subprg_Identifier; procedure Translate_Subprogram_Interfaces (Spec : Iir) is Inter : Iir; Mark : Id_Mark_Type; begin -- Set the identifier prefix with the subprogram identifier and -- overload number if any. Push_Subprg_Identifier (Spec, Mark); -- Translate interface types. Inter := Get_Interface_Declaration_Chain (Spec); while Inter /= Null_Iir loop Chap3.Translate_Object_Subtype (Inter); Inter := Get_Chain (Inter); end loop; Pop_Identifier_Prefix (Mark); end Translate_Subprogram_Interfaces; procedure Elab_Subprogram_Interfaces (Spec : Iir) is Inter : Iir; begin -- Translate interface types. Inter := Get_Interface_Declaration_Chain (Spec); while Inter /= Null_Iir loop Chap3.Elab_Object_Subtype (Get_Type (Inter)); Inter := Get_Chain (Inter); end loop; end Elab_Subprogram_Interfaces; -- Return the type of a subprogram interface. -- Return O_Tnode_Null if the parameter is passed through the -- interface record. function Translate_Interface_Type (Inter : Iir) return O_Tnode is Mode : Object_Kind_Type; Tinfo : constant Type_Info_Acc := Get_Info (Get_Type (Inter)); begin case Get_Kind (Inter) is when Iir_Kind_Interface_Constant_Declaration | Iir_Kind_Interface_Variable_Declaration | Iir_Kind_Interface_File_Declaration => Mode := Mode_Value; when Iir_Kind_Interface_Signal_Declaration => Mode := Mode_Signal; when others => Error_Kind ("translate_interface_type", Inter); end case; case Tinfo.Type_Mode is when Type_Mode_Unknown => raise Internal_Error; when Type_Mode_By_Value => return Tinfo.Ortho_Type (Mode); when Type_Mode_By_Copy | Type_Mode_By_Ref => return Tinfo.Ortho_Ptr_Type (Mode); end case; end Translate_Interface_Type; procedure Translate_Subprogram_Declaration (Spec : Iir) is Info : constant Subprg_Info_Acc := Get_Info (Spec); Is_Func : constant Boolean := Get_Kind (Spec) = Iir_Kind_Function_Declaration; Inter : Iir; Inter_Type : Iir; Arg_Info : Ortho_Info_Acc; Tinfo : Type_Info_Acc; Interface_List : O_Inter_List; Has_Result_Record : Boolean; El_List : O_Element_List; Mark : Id_Mark_Type; Rtype : Iir; Id : O_Ident; Storage : O_Storage; Foreign : Foreign_Info_Type := Foreign_Bad; begin -- Set the identifier prefix with the subprogram identifier and -- overload number if any. Push_Subprg_Identifier (Spec, Mark); if Get_Foreign_Flag (Spec) then -- Special handling for foreign subprograms. Foreign := Translate_Foreign_Id (Spec); case Foreign.Kind is when Foreign_Unknown => Id := Create_Identifier; when Foreign_Intrinsic => Id := Create_Identifier; when Foreign_Vhpidirect => Id := Get_Identifier (Name_Table.Nam_Buffer (Foreign.Subprg_First .. Foreign.Subprg_Last)); end case; Storage := O_Storage_External; else Id := Create_Identifier; Storage := Global_Storage; end if; if Is_Func then -- If the result of a function is a composite type for ortho, -- the result is allocated by the caller and an access to it is -- given to the function. Rtype := Get_Return_Type (Spec); Info.Use_Stack2 := False; Tinfo := Get_Info (Rtype); if Is_Composite (Tinfo) then Start_Procedure_Decl (Interface_List, Id, Storage); New_Interface_Decl (Interface_List, Info.Res_Interface, Get_Identifier ("RESULT"), Tinfo.Ortho_Ptr_Type (Mode_Value)); -- Furthermore, if the result type is unconstrained, the -- function will allocate it on a secondary stack. if not Is_Fully_Constrained_Type (Rtype) then Info.Use_Stack2 := True; end if; else -- Normal function. Start_Function_Decl (Interface_List, Id, Storage, Tinfo.Ortho_Type (Mode_Value)); Info.Res_Interface := O_Dnode_Null; end if; else -- Create info for each interface of the procedure. -- For parameters passed via copy and that needs a copy-out, -- gather them in a record. An access to the record is then -- passed to the procedure. Has_Result_Record := False; Inter := Get_Interface_Declaration_Chain (Spec); while Inter /= Null_Iir loop Arg_Info := Add_Info (Inter, Kind_Interface); Inter_Type := Get_Type (Inter); Tinfo := Get_Info (Inter_Type); if Get_Kind (Inter) = Iir_Kind_Interface_Variable_Declaration and then Get_Mode (Inter) in Iir_Out_Modes and then Tinfo.Type_Mode not in Type_Mode_By_Ref and then Tinfo.Type_Mode /= Type_Mode_File then -- This interface is done via the result record. -- Note: file passed through variables are vhdl87 files, -- which are initialized at elaboration and thus -- behave like an IN parameter. if not Has_Result_Record then -- Create the record. Start_Record_Type (El_List); Has_Result_Record := True; end if; -- Add a field to the record. New_Record_Field (El_List, Arg_Info.Interface_Field, Create_Identifier_Without_Prefix (Inter), Tinfo.Ortho_Type (Mode_Value)); else Arg_Info.Interface_Field := O_Fnode_Null; end if; Inter := Get_Chain (Inter); end loop; if Has_Result_Record then -- Declare the record type and an access to the record. Finish_Record_Type (El_List, Info.Res_Record_Type); New_Type_Decl (Create_Identifier ("RESTYPE"), Info.Res_Record_Type); Info.Res_Record_Ptr := New_Access_Type (Info.Res_Record_Type); New_Type_Decl (Create_Identifier ("RESPTR"), Info.Res_Record_Ptr); else Info.Res_Interface := O_Dnode_Null; end if; Start_Procedure_Decl (Interface_List, Id, Storage); if Has_Result_Record then -- Add the record parameter. New_Interface_Decl (Interface_List, Info.Res_Interface, Get_Identifier ("RESULT"), Info.Res_Record_Ptr); end if; end if; -- Instance parameter if any. if not Get_Foreign_Flag (Spec) then Subprgs.Create_Subprg_Instance (Interface_List, Spec); end if; -- Translate interfaces. Inter := Get_Interface_Declaration_Chain (Spec); while Inter /= Null_Iir loop if Is_Func then -- Create the info. Arg_Info := Add_Info (Inter, Kind_Interface); Arg_Info.Interface_Field := O_Fnode_Null; else -- The info was already created (just above) Arg_Info := Get_Info (Inter); end if; if Arg_Info.Interface_Field = O_Fnode_Null then -- Not via the RESULT parameter. Arg_Info.Interface_Type := Translate_Interface_Type (Inter); New_Interface_Decl (Interface_List, Arg_Info.Interface_Node, Create_Identifier_Without_Prefix (Inter), Arg_Info.Interface_Type); end if; Inter := Get_Chain (Inter); end loop; Finish_Subprogram_Decl (Interface_List, Info.Ortho_Func); -- Call the hook for foreign subprograms. if Get_Foreign_Flag (Spec) and then Foreign_Hook /= null then Foreign_Hook.all (Spec, Foreign, Info.Ortho_Func); end if; Save_Local_Identifier (Info.Subprg_Local_Id); Pop_Identifier_Prefix (Mark); end Translate_Subprogram_Declaration; -- Return TRUE iff subprogram specification SPEC is translated in an -- ortho function. function Is_Subprogram_Ortho_Function (Spec : Iir) return Boolean is begin if Get_Kind (Spec) = Iir_Kind_Procedure_Declaration then return False; end if; if Get_Info (Spec).Res_Interface /= O_Dnode_Null then return False; end if; return True; end Is_Subprogram_Ortho_Function; -- Return TRUE iif SUBPRG_BODY declares explicitely or implicitely -- (or even implicitely by translation) a subprogram. function Has_Nested_Subprograms (Subprg_Body : Iir) return Boolean is Decl : Iir; Atype : Iir; begin Decl := Get_Declaration_Chain (Subprg_Body); while Decl /= Null_Iir loop case Get_Kind (Decl) is when Iir_Kind_Function_Declaration | Iir_Kind_Procedure_Declaration => return True; when Iir_Kind_Function_Body | Iir_Kind_Procedure_Body => -- The declaration preceed the body. raise Internal_Error; when Iir_Kind_Type_Declaration | Iir_Kind_Anonymous_Type_Declaration => Atype := Get_Type_Definition (Decl); case Iir_Kinds_Type_And_Subtype_Definition (Get_Kind (Atype)) is when Iir_Kinds_Scalar_Type_Definition => null; when Iir_Kind_Access_Type_Definition | Iir_Kind_Access_Subtype_Definition => null; when Iir_Kind_File_Type_Definition => return True; when Iir_Kind_Protected_Type_Declaration => raise Internal_Error; when Iir_Kinds_Composite_Type_Definition => -- At least for "=". return True; when Iir_Kind_Incomplete_Type_Definition => null; end case; when others => null; end case; Decl := Get_Chain (Decl); end loop; return False; end Has_Nested_Subprograms; procedure Translate_Subprogram_Body (Subprg : Iir) is Spec : constant Iir := Get_Subprogram_Specification (Subprg); Info : constant Ortho_Info_Acc := Get_Info (Spec); Old_Subprogram : Iir; Mark : Id_Mark_Type; Final : Boolean; Is_Ortho_Func : Boolean; -- Set for a public method. In this case, the lock must be acquired -- and retained. Is_Prot : Boolean := False; -- True if the body has local (nested) subprograms. Has_Nested : Boolean; Frame_Ptr_Type : O_Tnode; Upframe_Field : O_Fnode; Frame : O_Dnode; Frame_Ptr : O_Dnode; Has_Return : Boolean; Prev_Subprg_Instances : Subprgs.Subprg_Instance_Stack; begin -- Do not translate body for foreign subprograms. if Get_Foreign_Flag (Spec) then return; end if; -- Check if there are nested subprograms to unnest. In that case, -- a frame record is created, which is less efficient than the -- use of local variables. if Flag_Unnest_Subprograms then Has_Nested := Has_Nested_Subprograms (Subprg); else Has_Nested := False; end if; -- Set the identifier prefix with the subprogram identifier and -- overload number if any. Push_Subprg_Identifier (Spec, Mark); Restore_Local_Identifier (Info.Subprg_Local_Id); if Has_Nested then -- Unnest subprograms. -- Create an instance for the local declarations. Push_Instance_Factory (Info.Subprg_Frame_Scope'Access); Add_Subprg_Instance_Field (Upframe_Field); if Info.Res_Record_Ptr /= O_Tnode_Null then Info.Res_Record_Var := Create_Var (Create_Var_Identifier ("RESULT"), Info.Res_Record_Ptr); end if; -- Create fields for parameters. -- FIXME: do it only if they are referenced in nested -- subprograms. declare Inter : Iir; Inter_Info : Inter_Info_Acc; begin Inter := Get_Interface_Declaration_Chain (Spec); while Inter /= Null_Iir loop Inter_Info := Get_Info (Inter); if Inter_Info.Interface_Node /= O_Dnode_Null then Inter_Info.Interface_Field := Add_Instance_Factory_Field (Create_Identifier_Without_Prefix (Inter), Inter_Info.Interface_Type); end if; Inter := Get_Chain (Inter); end loop; end; Chap4.Translate_Declaration_Chain (Subprg); Pop_Instance_Factory (Info.Subprg_Frame_Scope'Access); New_Type_Decl (Create_Identifier ("_FRAMETYPE"), Get_Scope_Type (Info.Subprg_Frame_Scope)); Declare_Scope_Acc (Info.Subprg_Frame_Scope, Create_Identifier ("_FRAMEPTR"), Frame_Ptr_Type); Rtis.Generate_Subprogram_Body (Subprg); -- Local frame Subprgs.Push_Subprg_Instance (Info.Subprg_Frame_Scope'Access, Frame_Ptr_Type, Wki_Upframe, Prev_Subprg_Instances); -- Link to previous frame Subprgs.Start_Prev_Subprg_Instance_Use_Via_Field (Prev_Subprg_Instances, Upframe_Field); Chap4.Translate_Declaration_Chain_Subprograms (Subprg); -- Link to previous frame Subprgs.Finish_Prev_Subprg_Instance_Use_Via_Field (Prev_Subprg_Instances, Upframe_Field); -- Local frame Subprgs.Pop_Subprg_Instance (Wki_Upframe, Prev_Subprg_Instances); end if; -- Create the body Start_Subprogram_Body (Info.Ortho_Func); Start_Subprg_Instance_Use (Spec); -- Variables will be created on the stack. Push_Local_Factory; -- Code has access to local (and outer) variables. -- FIXME: this is not necessary if Has_Nested is set Subprgs.Clear_Subprg_Instance (Prev_Subprg_Instances); -- There is a local scope for temporaries. Open_Local_Temp; if not Has_Nested then Chap4.Translate_Declaration_Chain (Subprg); Rtis.Generate_Subprogram_Body (Subprg); Chap4.Translate_Declaration_Chain_Subprograms (Subprg); else New_Var_Decl (Frame, Wki_Frame, O_Storage_Local, Get_Scope_Type (Info.Subprg_Frame_Scope)); New_Var_Decl (Frame_Ptr, Get_Identifier ("FRAMEPTR"), O_Storage_Local, Frame_Ptr_Type); New_Assign_Stmt (New_Obj (Frame_Ptr), New_Address (New_Obj (Frame), Frame_Ptr_Type)); -- FIXME: use direct reference (ie Frame instead of Frame_Ptr) Set_Scope_Via_Param_Ptr (Info.Subprg_Frame_Scope, Frame_Ptr); -- Set UPFRAME. Subprgs.Set_Subprg_Instance_Field (Frame_Ptr, Upframe_Field, Info.Subprg_Instance); if Info.Res_Record_Type /= O_Tnode_Null then -- Initialize the RESULT field New_Assign_Stmt (Get_Var (Info.Res_Record_Var), New_Obj_Value (Info.Res_Interface)); -- Do not reference the RESULT field in the subprogram body, -- directly reference the RESULT parameter. -- FIXME: has a flag (see below for parameters). Info.Res_Record_Var := Null_Var; end if; -- Copy parameters to FRAME. declare Inter : Iir; Inter_Info : Inter_Info_Acc; begin Inter := Get_Interface_Declaration_Chain (Spec); while Inter /= Null_Iir loop Inter_Info := Get_Info (Inter); if Inter_Info.Interface_Node /= O_Dnode_Null then New_Assign_Stmt (New_Selected_Element (New_Obj (Frame), Inter_Info.Interface_Field), New_Obj_Value (Inter_Info.Interface_Node)); -- Forget the reference to the field in FRAME, so that -- this subprogram will directly reference the parameter -- (and not its copy in the FRAME). Inter_Info.Interface_Field := O_Fnode_Null; end if; Inter := Get_Chain (Inter); end loop; end; end if; -- Init out parameters passed by value/copy. declare Inter : Iir; Inter_Type : Iir; Type_Info : Type_Info_Acc; begin Inter := Get_Interface_Declaration_Chain (Spec); while Inter /= Null_Iir loop if Get_Kind (Inter) = Iir_Kind_Interface_Variable_Declaration and then Get_Mode (Inter) = Iir_Out_Mode then Inter_Type := Get_Type (Inter); Type_Info := Get_Info (Inter_Type); if (Type_Info.Type_Mode in Type_Mode_By_Value or Type_Info.Type_Mode in Type_Mode_By_Copy) and then Type_Info.Type_Mode /= Type_Mode_File then Chap4.Init_Object (Chap6.Translate_Name (Inter), Inter_Type); end if; end if; Inter := Get_Chain (Inter); end loop; end; Chap4.Elab_Declaration_Chain (Subprg, Final); -- If finalization is required, create a dummy loop around the -- body and convert returns into exit out of this loop. -- If the subprogram is a function, also create a variable for the -- result. Is_Prot := Is_Subprogram_Method (Spec); if Final or Is_Prot then if Is_Prot then -- Lock the object. Chap3.Call_Ghdl_Protected_Procedure (Get_Method_Type (Spec), Ghdl_Protected_Enter); end if; Is_Ortho_Func := Is_Subprogram_Ortho_Function (Spec); if Is_Ortho_Func then New_Var_Decl (Info.Subprg_Result, Get_Identifier ("RESULT"), O_Storage_Local, Get_Ortho_Type (Get_Return_Type (Spec), Mode_Value)); end if; Start_Loop_Stmt (Info.Subprg_Exit); end if; Old_Subprogram := Current_Subprogram; Current_Subprogram := Spec; Has_Return := Chap8.Translate_Statements_Chain_Has_Return (Get_Sequential_Statement_Chain (Subprg)); Current_Subprogram := Old_Subprogram; if Final or Is_Prot then -- Create a barrier to catch missing return statement. if Get_Kind (Spec) = Iir_Kind_Procedure_Declaration then New_Exit_Stmt (Info.Subprg_Exit); else if not Has_Return then -- Missing return Chap6.Gen_Program_Error (Subprg, Chap6.Prg_Err_Missing_Return); end if; end if; Finish_Loop_Stmt (Info.Subprg_Exit); Chap4.Final_Declaration_Chain (Subprg, False); if Is_Prot then -- Unlock the object. Chap3.Call_Ghdl_Protected_Procedure (Get_Method_Type (Spec), Ghdl_Protected_Leave); end if; if Is_Ortho_Func then New_Return_Stmt (New_Obj_Value (Info.Subprg_Result)); end if; else if Get_Kind (Spec) = Iir_Kind_Function_Declaration and then not Has_Return then -- Missing return Chap6.Gen_Program_Error (Subprg, Chap6.Prg_Err_Missing_Return); end if; end if; if Has_Nested then Clear_Scope (Info.Subprg_Frame_Scope); end if; Subprgs.Pop_Subprg_Instance (O_Ident_Nul, Prev_Subprg_Instances); Close_Local_Temp; Pop_Local_Factory; Finish_Subprg_Instance_Use (Spec); Finish_Subprogram_Body; Pop_Identifier_Prefix (Mark); end Translate_Subprogram_Body; procedure Translate_Package_Declaration (Decl : Iir_Package_Declaration) is Header : constant Iir := Get_Package_Header (Decl); Info : Ortho_Info_Acc; Interface_List : O_Inter_List; Prev_Subprg_Instance : Subprgs.Subprg_Instance_Stack; begin Info := Add_Info (Decl, Kind_Package); -- Translate declarations. if Is_Uninstantiated_Package (Decl) then -- Create an instance for the spec. Push_Instance_Factory (Info.Package_Spec_Scope'Access); Chap4.Translate_Generic_Chain (Header); Chap4.Translate_Declaration_Chain (Decl); Info.Package_Elab_Var := Create_Var (Create_Var_Identifier ("ELABORATED"), Ghdl_Bool_Type); Pop_Instance_Factory (Info.Package_Spec_Scope'Access); -- Name the spec instance and create a pointer. New_Type_Decl (Create_Identifier ("SPECINSTTYPE"), Get_Scope_Type (Info.Package_Spec_Scope)); Declare_Scope_Acc (Info.Package_Spec_Scope, Create_Identifier ("SPECINSTPTR"), Info.Package_Spec_Ptr_Type); -- Create an instance and its pointer for the body. Chap2.Declare_Inst_Type_And_Ptr (Info.Package_Body_Scope'Access, Info.Package_Body_Ptr_Type); -- Each subprogram has a body instance argument. Subprgs.Push_Subprg_Instance (Info.Package_Body_Scope'Access, Info.Package_Body_Ptr_Type, Wki_Instance, Prev_Subprg_Instance); else Chap4.Translate_Declaration_Chain (Decl); Info.Package_Elab_Var := Create_Var (Create_Var_Identifier ("ELABORATED"), Ghdl_Bool_Type); end if; -- Translate subprograms declarations. Chap4.Translate_Declaration_Chain_Subprograms (Decl); -- Declare elaborator for the body. Start_Procedure_Decl (Interface_List, Create_Identifier ("ELAB_BODY"), Global_Storage); Subprgs.Add_Subprg_Instance_Interfaces (Interface_List, Info.Package_Elab_Body_Instance); Finish_Subprogram_Decl (Interface_List, Info.Package_Elab_Body_Subprg); if Is_Uninstantiated_Package (Decl) then Subprgs.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); -- The spec elaborator has a spec instance argument. Subprgs.Push_Subprg_Instance (Info.Package_Spec_Scope'Access, Info.Package_Spec_Ptr_Type, Wki_Instance, Prev_Subprg_Instance); end if; Start_Procedure_Decl (Interface_List, Create_Identifier ("ELAB_SPEC"), Global_Storage); Subprgs.Add_Subprg_Instance_Interfaces (Interface_List, Info.Package_Elab_Spec_Instance); Finish_Subprogram_Decl (Interface_List, Info.Package_Elab_Spec_Subprg); if Flag_Rti then -- Generate RTI. Rtis.Generate_Unit (Decl); end if; if Global_Storage = O_Storage_Public then -- Create elaboration procedure for the spec Elab_Package (Decl); end if; if Is_Uninstantiated_Package (Decl) then Subprgs.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); end if; Save_Local_Identifier (Info.Package_Local_Id); end Translate_Package_Declaration; procedure Translate_Package_Body (Decl : Iir_Package_Body) is Spec : constant Iir_Package_Declaration := Get_Package (Decl); Info : constant Ortho_Info_Acc := Get_Info (Spec); Prev_Subprg_Instance : Subprgs.Subprg_Instance_Stack; begin -- Translate declarations. if Is_Uninstantiated_Package (Spec) then Push_Instance_Factory (Info.Package_Body_Scope'Access); Info.Package_Spec_Field := Add_Instance_Factory_Field (Get_Identifier ("SPEC"), Get_Scope_Type (Info.Package_Spec_Scope)); Chap4.Translate_Declaration_Chain (Decl); Pop_Instance_Factory (Info.Package_Body_Scope'Access); if Global_Storage = O_Storage_External then return; end if; else -- May be called during elaboration to generate RTI. if Global_Storage = O_Storage_External then return; end if; Restore_Local_Identifier (Get_Info (Spec).Package_Local_Id); Chap4.Translate_Declaration_Chain (Decl); end if; if Flag_Rti then Rtis.Generate_Unit (Decl); end if; if Is_Uninstantiated_Package (Spec) then Subprgs.Push_Subprg_Instance (Info.Package_Body_Scope'Access, Info.Package_Body_Ptr_Type, Wki_Instance, Prev_Subprg_Instance); Set_Scope_Via_Field (Info.Package_Spec_Scope, Info.Package_Spec_Field, Info.Package_Body_Scope'Access); end if; Chap4.Translate_Declaration_Chain_Subprograms (Decl); if Is_Uninstantiated_Package (Spec) then Clear_Scope (Info.Package_Spec_Scope); Subprgs.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); end if; Elab_Package_Body (Spec, Decl); end Translate_Package_Body; procedure Elab_Package (Spec : Iir_Package_Declaration) is Info : constant Ortho_Info_Acc := Get_Info (Spec); Final : Boolean; Constr : O_Assoc_List; pragma Unreferenced (Final); begin Start_Subprogram_Body (Info.Package_Elab_Spec_Subprg); Push_Local_Factory; Subprgs.Start_Subprg_Instance_Use (Info.Package_Elab_Spec_Instance); Elab_Dependence (Get_Design_Unit (Spec)); if not Is_Uninstantiated_Package (Spec) and then Get_Kind (Get_Parent (Spec)) = Iir_Kind_Design_Unit then -- Register the top level package. This is done dynamically, as -- we know only during elaboration that the design depends on a -- package (a package maybe referenced by an entity which is never -- instantiated due to generate statements). Start_Association (Constr, Ghdl_Rti_Add_Package); New_Association (Constr, New_Lit (Rtis.New_Rti_Address (Info.Package_Rti_Const))); New_Procedure_Call (Constr); end if; Open_Temp; Chap4.Elab_Declaration_Chain (Spec, Final); Close_Temp; Subprgs.Finish_Subprg_Instance_Use (Info.Package_Elab_Spec_Instance); Pop_Local_Factory; Finish_Subprogram_Body; end Elab_Package; procedure Elab_Package_Body (Spec : Iir_Package_Declaration; Bod : Iir) is Info : constant Ortho_Info_Acc := Get_Info (Spec); If_Blk : O_If_Block; Constr : O_Assoc_List; Final : Boolean; begin Start_Subprogram_Body (Info.Package_Elab_Body_Subprg); Push_Local_Factory; Subprgs.Start_Subprg_Instance_Use (Info.Package_Elab_Body_Instance); if Is_Uninstantiated_Package (Spec) then Set_Scope_Via_Field (Info.Package_Spec_Scope, Info.Package_Spec_Field, Info.Package_Body_Scope'Access); end if; -- If the package was already elaborated, return now, -- else mark the package as elaborated. Start_If_Stmt (If_Blk, New_Value (Get_Var (Info.Package_Elab_Var))); New_Return_Stmt; New_Else_Stmt (If_Blk); New_Assign_Stmt (Get_Var (Info.Package_Elab_Var), New_Lit (Ghdl_Bool_True_Node)); Finish_If_Stmt (If_Blk); -- Elab Spec. Start_Association (Constr, Info.Package_Elab_Spec_Subprg); Add_Subprg_Instance_Assoc (Constr, Info.Package_Elab_Spec_Instance); New_Procedure_Call (Constr); if Bod /= Null_Iir then Elab_Dependence (Get_Design_Unit (Bod)); Open_Temp; Chap4.Elab_Declaration_Chain (Bod, Final); Close_Temp; end if; if Is_Uninstantiated_Package (Spec) then Clear_Scope (Info.Package_Spec_Scope); end if; Subprgs.Finish_Subprg_Instance_Use (Info.Package_Elab_Body_Instance); Pop_Local_Factory; Finish_Subprogram_Body; end Elab_Package_Body; procedure Instantiate_Iir_Info (N : Iir); procedure Instantiate_Iir_Chain_Info (Chain : Iir) is N : Iir; begin N := Chain; while N /= Null_Iir loop Instantiate_Iir_Info (N); N := Get_Chain (N); end loop; end Instantiate_Iir_Chain_Info; procedure Instantiate_Iir_List_Info (L : Iir_List) is El : Iir; begin case L is when Null_Iir_List | Iir_List_All | Iir_List_Others => return; when others => for I in Natural loop El := Get_Nth_Element (L, I); exit when El = Null_Iir; Instantiate_Iir_Info (El); end loop; end case; end Instantiate_Iir_List_Info; procedure Copy_Info (Dest : Ortho_Info_Acc; Src : Ortho_Info_Acc) is begin case Src.Kind is when Kind_Type => Dest.all := (Kind => Kind_Type, Type_Mode => Src.Type_Mode, Type_Incomplete => Src.Type_Incomplete, Type_Locally_Constrained => Src.Type_Locally_Constrained, C => null, Ortho_Type => Src.Ortho_Type, Ortho_Ptr_Type => Src.Ortho_Ptr_Type, Type_Transient_Chain => Null_Iir, T => Src.T, Type_Rti => Src.Type_Rti); pragma Assert (Src.C = null); pragma Assert (Src.Type_Transient_Chain = Null_Iir); when Kind_Object => pragma Assert (Src.Object_Driver = Null_Var); pragma Assert (Src.Object_Function = O_Dnode_Null); Dest.all := (Kind => Kind_Object, Object_Static => Src.Object_Static, Object_Var => Instantiate_Var (Src.Object_Var), Object_Driver => Null_Var, Object_Rti => Src.Object_Rti, Object_Function => O_Dnode_Null); when Kind_Subprg => Dest.Subprg_Frame_Scope := Instantiate_Var_Scope (Src.Subprg_Frame_Scope); Dest.all := (Kind => Kind_Subprg, Use_Stack2 => Src.Use_Stack2, Ortho_Func => Src.Ortho_Func, Res_Interface => Src.Res_Interface, Res_Record_Var => Instantiate_Var (Src.Res_Record_Var), Res_Record_Type => Src.Res_Record_Type, Res_Record_Ptr => Src.Res_Record_Ptr, Subprg_Frame_Scope => Dest.Subprg_Frame_Scope, Subprg_Instance => Instantiate_Subprg_Instance (Src.Subprg_Instance), Subprg_Resolv => null, Subprg_Local_Id => Src.Subprg_Local_Id, Subprg_Exit => Src.Subprg_Exit, Subprg_Result => Src.Subprg_Result); when Kind_Interface => Dest.all := (Kind => Kind_Interface, Interface_Node => Src.Interface_Node, Interface_Field => Src.Interface_Field, Interface_Type => Src.Interface_Type); when Kind_Index => Dest.all := (Kind => Kind_Index, Index_Field => Src.Index_Field); when Kind_Expr => Dest.all := (Kind => Kind_Expr, Expr_Node => Src.Expr_Node); when others => raise Internal_Error; end case; end Copy_Info; procedure Instantiate_Iir_Info (N : Iir) is begin -- Nothing to do for null node. if N = Null_Iir then return; end if; declare use Nodes_Meta; Kind : constant Iir_Kind := Get_Kind (N); Fields : constant Fields_Array := Get_Fields (Kind); F : Fields_Enum; Orig : constant Iir := Sem_Inst.Get_Origin (N); pragma Assert (Orig /= Null_Iir); Orig_Info : constant Ortho_Info_Acc := Get_Info (Orig); Info : Ortho_Info_Acc; begin if Orig_Info /= null then Info := Add_Info (N, Orig_Info.Kind); Copy_Info (Info, Orig_Info); case Info.Kind is when Kind_Subprg => Push_Instantiate_Var_Scope (Info.Subprg_Frame_Scope'Access, Orig_Info.Subprg_Frame_Scope'Access); when others => null; end case; end if; for I in Fields'Range loop F := Fields (I); case Get_Field_Type (F) is when Type_Iir => case Get_Field_Attribute (F) is when Attr_None => Instantiate_Iir_Info (Get_Iir (N, F)); when Attr_Ref => null; when Attr_Maybe_Ref => if not Get_Is_Ref (N) then Instantiate_Iir_Info (Get_Iir (N, F)); end if; when Attr_Chain => Instantiate_Iir_Chain_Info (Get_Iir (N, F)); when Attr_Chain_Next => null; when Attr_Of_Ref => raise Internal_Error; end case; when Type_Iir_List => case Get_Field_Attribute (F) is when Attr_None => Instantiate_Iir_List_Info (Get_Iir_List (N, F)); when Attr_Ref | Attr_Of_Ref => null; when others => raise Internal_Error; end case; when Type_PSL_NFA | Type_PSL_Node => -- TODO raise Internal_Error; when Type_Date_Type | Type_Date_State_Type | Type_Time_Stamp_Id => -- Can this happen ? raise Internal_Error; when Type_String8_Id | Type_Source_Ptr | Type_Base_Type | Type_Iir_Constraint | Type_Iir_Mode | Type_Iir_Index32 | Type_Iir_Int64 | Type_Boolean | Type_Iir_Staticness | Type_Iir_All_Sensitized | Type_Iir_Signal_Kind | Type_Tri_State_Type | Type_Iir_Pure_State | Type_Iir_Delay_Mechanism | Type_Iir_Predefined_Functions | Type_Iir_Direction | Type_Location_Type | Type_Iir_Int32 | Type_Int32 | Type_Iir_Fp64 | Type_Token_Type | Type_Name_Id => null; end case; end loop; if Info /= null then case Info.Kind is when Kind_Subprg => Pop_Instantiate_Var_Scope (Info.Subprg_Frame_Scope'Access); when others => null; end case; end if; end; end Instantiate_Iir_Info; procedure Instantiate_Iir_Generic_Chain_Info (Chain : Iir) is Inter : Iir; Orig : Iir; Orig_Info : Ortho_Info_Acc; Info : Ortho_Info_Acc; begin Inter := Chain; while Inter /= Null_Iir loop case Get_Kind (Inter) is when Iir_Kind_Interface_Constant_Declaration => Orig := Sem_Inst.Get_Origin (Inter); Orig_Info := Get_Info (Orig); Info := Add_Info (Inter, Orig_Info.Kind); Copy_Info (Info, Orig_Info); when Iir_Kind_Interface_Package_Declaration => null; when others => raise Internal_Error; end case; Inter := Get_Chain (Inter); end loop; end Instantiate_Iir_Generic_Chain_Info; -- Add info for an interface_package_declaration or a -- package_instantiation_declaration procedure Instantiate_Info_Package (Inst : Iir) is Spec : constant Iir := Get_Named_Entity (Get_Uninstantiated_Package_Name (Inst)); Pkg_Info : constant Ortho_Info_Acc := Get_Info (Spec); Info : Ortho_Info_Acc; begin Info := Add_Info (Inst, Kind_Package_Instance); -- Create the info instances. Push_Instantiate_Var_Scope (Info.Package_Instance_Spec_Scope'Access, Pkg_Info.Package_Spec_Scope'Access); Push_Instantiate_Var_Scope (Info.Package_Instance_Body_Scope'Access, Pkg_Info.Package_Body_Scope'Access); Instantiate_Iir_Generic_Chain_Info (Get_Generic_Chain (Inst)); Instantiate_Iir_Chain_Info (Get_Declaration_Chain (Inst)); Pop_Instantiate_Var_Scope (Info.Package_Instance_Body_Scope'Access); Pop_Instantiate_Var_Scope (Info.Package_Instance_Spec_Scope'Access); end Instantiate_Info_Package; procedure Translate_Package_Instantiation_Declaration (Inst : Iir) is Spec : constant Iir := Get_Named_Entity (Get_Uninstantiated_Package_Name (Inst)); Pkg_Info : constant Ortho_Info_Acc := Get_Info (Spec); Info : Ortho_Info_Acc; Interface_List : O_Inter_List; Constr : O_Assoc_List; begin Instantiate_Info_Package (Inst); Info := Get_Info (Inst); -- FIXME: if the instantiation occurs within a package declaration, -- the variable must be declared extern (and public in the body). Info.Package_Instance_Body_Var := Create_Var (Create_Var_Identifier (Inst), Get_Scope_Type (Pkg_Info.Package_Body_Scope)); -- FIXME: this is correct only for global instantiation, and only if -- there is only one. Set_Scope_Via_Decl (Info.Package_Instance_Body_Scope, Get_Var_Label (Info.Package_Instance_Body_Var)); Set_Scope_Via_Field (Info.Package_Instance_Spec_Scope, Pkg_Info.Package_Spec_Field, Info.Package_Instance_Body_Scope'Access); -- Declare elaboration procedure Start_Procedure_Decl (Interface_List, Create_Identifier ("ELAB"), Global_Storage); -- Chap2.Add_Subprg_Instance_Interfaces -- (Interface_List, Info.Package_Instance_Elab_Instance); Finish_Subprogram_Decl (Interface_List, Info.Package_Instance_Elab_Subprg); if Global_Storage /= O_Storage_Public then return; end if; -- Elaborator: Start_Subprogram_Body (Info.Package_Instance_Elab_Subprg); -- Chap2.Start_Subprg_Instance_Use -- (Info.Package_Instance_Elab_Instance); Elab_Dependence (Get_Design_Unit (Inst)); Set_Scope_Via_Decl (Pkg_Info.Package_Body_Scope, Get_Var_Label (Info.Package_Instance_Body_Var)); Set_Scope_Via_Field (Pkg_Info.Package_Spec_Scope, Pkg_Info.Package_Spec_Field, Pkg_Info.Package_Body_Scope'Access); Chap5.Elab_Generic_Map_Aspect (Inst); Clear_Scope (Pkg_Info.Package_Spec_Scope); Clear_Scope (Pkg_Info.Package_Body_Scope); -- Call the elaborator of the generic. The generic must be -- temporary associated with the instance variable. Start_Association (Constr, Pkg_Info.Package_Elab_Body_Subprg); Set_Scope_Via_Decl (Pkg_Info.Package_Body_Scope, Get_Var_Label (Info.Package_Instance_Body_Var)); Add_Subprg_Instance_Assoc (Constr, Pkg_Info.Package_Elab_Body_Instance); Clear_Scope (Pkg_Info.Package_Body_Scope); New_Procedure_Call (Constr); -- Chap2.Finish_Subprg_Instance_Use -- (Info.Package_Instance_Elab_Instance); Finish_Subprogram_Body; end Translate_Package_Instantiation_Declaration; procedure Elab_Dependence_Package (Pkg : Iir_Package_Declaration) is Info : Ortho_Info_Acc; If_Blk : O_If_Block; Constr : O_Assoc_List; begin -- Std.Standard is pre-elaborated. if Pkg = Standard_Package then return; end if; -- Nothing to do for uninstantiated package. if Is_Uninstantiated_Package (Pkg) then return; end if; -- Call the package elaborator only if not already elaborated. Info := Get_Info (Pkg); Start_If_Stmt (If_Blk, New_Monadic_Op (ON_Not, New_Value (Get_Var (Info.Package_Elab_Var)))); -- Elaborates only non-elaborated packages. Start_Association (Constr, Info.Package_Elab_Body_Subprg); New_Procedure_Call (Constr); Finish_If_Stmt (If_Blk); end Elab_Dependence_Package; procedure Elab_Dependence_Package_Instantiation (Pkg : Iir) is Info : constant Ortho_Info_Acc := Get_Info (Pkg); Constr : O_Assoc_List; begin Start_Association (Constr, Info.Package_Instance_Elab_Subprg); New_Procedure_Call (Constr); end Elab_Dependence_Package_Instantiation; procedure Elab_Dependence (Design_Unit: Iir_Design_Unit) is Depend_List : Iir_Design_Unit_List; Design : Iir; Library_Unit: Iir; begin Depend_List := Get_Dependence_List (Design_Unit); for I in Natural loop Design := Get_Nth_Element (Depend_List, I); exit when Design = Null_Iir; if Get_Kind (Design) = Iir_Kind_Design_Unit then Library_Unit := Get_Library_Unit (Design); case Get_Kind (Library_Unit) is when Iir_Kind_Package_Declaration => Elab_Dependence_Package (Library_Unit); when Iir_Kind_Package_Instantiation_Declaration => Elab_Dependence_Package_Instantiation (Library_Unit); when Iir_Kind_Entity_Declaration => -- FIXME: architecture already elaborates its entity. null; when Iir_Kind_Configuration_Declaration => null; when Iir_Kind_Architecture_Body => null; when Iir_Kind_Package_Body => -- A package instantiation depends on the body. null; when others => Error_Kind ("elab_dependence", Library_Unit); end case; end if; end loop; end Elab_Dependence; procedure Declare_Inst_Type_And_Ptr (Scope : Var_Scope_Acc; Ptr_Type : out O_Tnode) is begin Predeclare_Scope_Type (Scope.all, Create_Identifier ("INSTTYPE")); Declare_Scope_Acc (Scope.all, Create_Identifier ("INSTPTR"), Ptr_Type); end Declare_Inst_Type_And_Ptr; end Trans.Chap2;