diff options
Diffstat (limited to 'src/simulate')
24 files changed, 15671 insertions, 0 deletions
diff --git a/src/simulate/annotations.adb b/src/simulate/annotations.adb new file mode 100644 index 000000000..d07a99818 --- /dev/null +++ b/src/simulate/annotations.adb @@ -0,0 +1,1236 @@ +-- Annotations for interpreted simulation +-- Copyright (C) 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 GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with GNAT.Table; +with Ada.Text_IO; +with Std_Package; +with Errorout; use Errorout; +with Iirs_Utils; use Iirs_Utils; + +package body Annotations is + -- Current scope level. + Current_Scope_Level: Scope_Level_Type := Scope_Level_Global; + + procedure Annotate_Declaration_List + (Block_Info: Sim_Info_Acc; Decl_Chain: Iir); + procedure Annotate_Sequential_Statement_Chain + (Block_Info: Sim_Info_Acc; Stmt_Chain: Iir); + procedure Annotate_Concurrent_Statements_List + (Block_Info: Sim_Info_Acc; Stmt_Chain: Iir); + procedure Annotate_Block_Configuration + (Block : Iir_Block_Configuration); + procedure Annotate_Subprogram_Interfaces_Type + (Block_Info : Sim_Info_Acc; Subprg: Iir); + procedure Annotate_Subprogram_Specification + (Block_Info : Sim_Info_Acc; Subprg: Iir); + + procedure Annotate_Type_Definition (Block_Info: Sim_Info_Acc; Def: Iir); + + -- Annotate type definition DEF only if it is anonymous. + procedure Annotate_Anonymous_Type_Definition + (Block_Info: Sim_Info_Acc; Def: Iir); + + -- Be sure the node contains no informations. + procedure Assert_No_Info (Node: in Iir) is + begin + if Get_Info (Node) /= null then + raise Internal_Error; + end if; + end Assert_No_Info; + + procedure Increment_Current_Scope_Level is + begin + if Current_Scope_Level < Scope_Level_Global then + -- For a subprogram in a package + Current_Scope_Level := Scope_Level_Global + 1; + else + Current_Scope_Level := Current_Scope_Level + 1; + end if; + end Increment_Current_Scope_Level; + + -- Add an annotation to object OBJ. + procedure Create_Object_Info + (Block_Info : Sim_Info_Acc; + Obj : Iir; + Obj_Kind : Sim_Info_Kind := Kind_Object) + is + Info : Sim_Info_Acc; + begin + Block_Info.Nbr_Objects := Block_Info.Nbr_Objects + 1; + case Obj_Kind is + when Kind_Object => + Info := new Sim_Info_Type'(Kind => Kind_Object, + Scope_Level => Current_Scope_Level, + Slot => Block_Info.Nbr_Objects); + when Kind_File => + Info := new Sim_Info_Type'(Kind => Kind_File, + Scope_Level => Current_Scope_Level, + Slot => Block_Info.Nbr_Objects); + when Kind_Signal => + Info := new Sim_Info_Type'(Kind => Kind_Signal, + Scope_Level => Current_Scope_Level, + Slot => Block_Info.Nbr_Objects); + -- Reserve one more slot for default value. + Block_Info.Nbr_Objects := Block_Info.Nbr_Objects + 1; + when Kind_Terminal => + Info := new Sim_Info_Type'(Kind => Kind_Terminal, + Scope_Level => Current_Scope_Level, + Slot => Block_Info.Nbr_Objects); + when Kind_Quantity => + Info := new Sim_Info_Type'(Kind => Kind_Quantity, + Scope_Level => Current_Scope_Level, + Slot => Block_Info.Nbr_Objects); + when others => + raise Internal_Error; + end case; + Set_Info (Obj, Info); + end Create_Object_Info; + + -- Add an annotation to SIGNAL. + procedure Add_Signal_Info (Block_Info: Sim_Info_Acc; Signal: Iir) is + begin + Create_Object_Info (Block_Info, Signal, Kind_Signal); + end Add_Signal_Info; + + procedure Add_Terminal_Info (Block_Info: Sim_Info_Acc; Terminal : Iir) is + begin + Create_Object_Info (Block_Info, Terminal, Kind_Terminal); + end Add_Terminal_Info; + + procedure Add_Quantity_Info (Block_Info: Sim_Info_Acc; Quantity : Iir) is + begin + Create_Object_Info (Block_Info, Quantity, Kind_Quantity); + end Add_Quantity_Info; + + -- If EXPR has not a literal value, create one. + -- This is necessary for subtype bounds. + procedure Annotate_Range_Expression + (Block_Info: Sim_Info_Acc; Expr: Iir_Range_Expression) + is + begin + if Get_Info (Expr) /= null then + return; + end if; + Assert_No_Info (Expr); +-- if Expr = null or else Get_Info (Expr) /= null then +-- return; +-- end if; + Create_Object_Info (Block_Info, Expr); + end Annotate_Range_Expression; + + -- Annotate type definition DEF only if it is anonymous. + procedure Annotate_Anonymous_Type_Definition + (Block_Info: Sim_Info_Acc; Def: Iir) + is + begin + if Is_Anonymous_Type_Definition (Def) then + Annotate_Type_Definition (Block_Info, Def); + end if; + end Annotate_Anonymous_Type_Definition; + + function Get_File_Signature_Length (Def : Iir) return Natural is + begin + case Get_Kind (Def) is + when Iir_Kinds_Scalar_Type_Definition => + return 1; + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + return 2 + + Get_File_Signature_Length (Get_Element_Subtype (Def)); + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + declare + El : Iir; + Res : Natural; + List : Iir_List; + begin + Res := 2; + List := Get_Elements_Declaration_List (Get_Base_Type (Def)); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Res := Res + Get_File_Signature_Length (Get_Type (El)); + end loop; + return Res; + end; + when others => + Error_Kind ("get_file_signature_length", Def); + end case; + end Get_File_Signature_Length; + + procedure Get_File_Signature (Def : Iir; + Res : in out String; + Off : in out Natural) + is + Scalar_Map : constant array (Iir_Value_Scalars) of Character := "bEIF"; + begin + case Get_Kind (Def) is + when Iir_Kinds_Scalar_Type_Definition => + Res (Off) := + Scalar_Map (Get_Info (Get_Base_Type (Def)).Scalar_Mode); + Off := Off + 1; + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + Res (Off) := '['; + Off := Off + 1; + Get_File_Signature (Get_Element_Subtype (Def), Res, Off); + Res (Off) := ']'; + Off := Off + 1; + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + declare + El : Iir; + List : Iir_List; + begin + Res (Off) := '<'; + Off := Off + 1; + List := Get_Elements_Declaration_List (Get_Base_Type (Def)); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Get_File_Signature (Get_Type (El), Res, Off); + end loop; + Res (Off) := '>'; + Off := Off + 1; + end; + when others => + Error_Kind ("get_file_signature", Def); + end case; + end Get_File_Signature; + + procedure Annotate_Protected_Type_Declaration (Block_Info : Sim_Info_Acc; + Prot: Iir) + is + Prev_Scope_Level : constant Scope_Level_Type := Current_Scope_Level; + Decl : Iir; + begin + -- First the interfaces type (they are elaborated in their context). + Decl := Get_Declaration_Chain (Prot); + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + Annotate_Subprogram_Interfaces_Type (Block_Info, Decl); + when Iir_Kind_Use_Clause => + null; + when others => + -- FIXME: attribute + Error_Kind ("annotate_protected_type_declaration", Decl); + end case; + Decl := Get_Chain (Decl); + end loop; + + -- Then the interfaces object. Increment the scope to reserve a scope + -- for the protected object. + Increment_Current_Scope_Level; + + Decl := Get_Declaration_Chain (Prot); + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + Annotate_Subprogram_Specification (Block_Info, Decl); + when Iir_Kind_Use_Clause => + null; + when others => + Error_Kind ("annotate_protected_type_declaration", Decl); + end case; + Decl := Get_Chain (Decl); + end loop; + + Current_Scope_Level := Prev_Scope_Level; + end Annotate_Protected_Type_Declaration; + + procedure Annotate_Protected_Type_Body (Block_Info : Sim_Info_Acc; + Prot: Iir) + is + pragma Unreferenced (Block_Info); + Prot_Info: Sim_Info_Acc; + Prev_Scope_Level : constant Scope_Level_Type := Current_Scope_Level; + begin + Increment_Current_Scope_Level; + + Assert_No_Info (Prot); + + Prot_Info := + new Sim_Info_Type'(Kind => Kind_Frame, + Inst_Slot => 0, + Frame_Scope_Level => Current_Scope_Level, + Nbr_Objects => 0, + Nbr_Instances => 0); + Set_Info (Prot, Prot_Info); + + Annotate_Declaration_List + (Prot_Info, Get_Declaration_Chain (Prot)); + + Current_Scope_Level := Prev_Scope_Level; + end Annotate_Protected_Type_Body; + + procedure Annotate_Type_Definition (Block_Info: Sim_Info_Acc; Def: Iir) + is + El: Iir; + begin + -- Happen only with universal types. + if Def = Null_Iir then + return; + end if; + + case Get_Kind (Def) is + when Iir_Kind_Enumeration_Type_Definition => + if Def = Std_Package.Boolean_Type_Definition + or else Def = Std_Package.Bit_Type_Definition + then + Set_Info (Def, + new Sim_Info_Type'(Kind => Kind_Scalar_Type, + Scalar_Mode => Iir_Value_B1)); + else + Set_Info (Def, + new Sim_Info_Type'(Kind => Kind_Scalar_Type, + Scalar_Mode => Iir_Value_E32)); + end if; + Annotate_Range_Expression (Block_Info, Get_Range_Constraint (Def)); + + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition => + El := Get_Range_Constraint (Def); + if El /= Null_Iir then + case Get_Kind (El) is + when Iir_Kind_Range_Expression => + Annotate_Range_Expression (Block_Info, El); + -- A physical subtype may be defined by an integer range. + if Get_Kind (Def) = Iir_Kind_Physical_Subtype_Definition + then + null; + -- FIXME + -- Convert_Int_To_Phys (Get_Info (El).Value); + end if; + when Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute => + null; + when others => + Error_Kind ("annotate_type_definition (rc)", El); + end case; + end if; + Annotate_Anonymous_Type_Definition + (Block_Info, Get_Base_Type (Def)); + + when Iir_Kind_Integer_Type_Definition => + Set_Info (Def, + new Sim_Info_Type'(Kind => Kind_Scalar_Type, + Scalar_Mode => Iir_Value_I64)); + + when Iir_Kind_Floating_Type_Definition => + Set_Info (Def, + new Sim_Info_Type'(Kind => Kind_Scalar_Type, + Scalar_Mode => Iir_Value_F64)); + + when Iir_Kind_Physical_Type_Definition => + Set_Info (Def, + new Sim_Info_Type'(Kind => Kind_Scalar_Type, + Scalar_Mode => Iir_Value_I64)); + + when Iir_Kind_Array_Type_Definition => + El := Get_Element_Subtype (Def); + Annotate_Anonymous_Type_Definition (Block_Info, El); + + when Iir_Kind_Array_Subtype_Definition => + declare + List : constant Iir_List := Get_Index_Subtype_List (Def); + begin + for I in Natural loop + El := Get_Index_Type (List, I); + exit when El = Null_Iir; + Annotate_Anonymous_Type_Definition (Block_Info, El); + end loop; + end; + + when Iir_Kind_Record_Type_Definition => + declare + List : constant Iir_List := Get_Elements_Declaration_List (Def); + begin + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Annotate_Anonymous_Type_Definition + (Block_Info, Get_Type (El)); + end loop; + end; + + when Iir_Kind_Record_Subtype_Definition => + null; + + when Iir_Kind_Access_Type_Definition => + Annotate_Anonymous_Type_Definition + (Block_Info, Get_Designated_Type (Def)); + + when Iir_Kind_Access_Subtype_Definition => + null; + + when Iir_Kind_File_Type_Definition => + declare + Type_Name : constant Iir := Get_Type (Get_File_Type_Mark (Def)); + Res : String_Acc; + begin + if Get_Text_File_Flag (Def) + or else + Get_Kind (Type_Name) in Iir_Kinds_Scalar_Type_Definition + then + Res := null; + else + declare + Sig : String + (1 .. Get_File_Signature_Length (Type_Name) + 2); + Off : Natural := Sig'First; + begin + Get_File_Signature (Type_Name, Sig, Off); + Sig (Off + 0) := '.'; + Sig (Off + 1) := ASCII.NUL; + Res := new String'(Sig); + end; + end if; + Set_Info (Def, + new Sim_Info_Type'(Kind => Kind_File_Type, + File_Signature => Res)); + end; + + when Iir_Kind_Protected_Type_Declaration => + Annotate_Protected_Type_Declaration (Block_Info, Def); + + when Iir_Kind_Incomplete_Type_Definition => + null; + + when others => + Error_Kind ("annotate_type_definition", Def); + end case; + end Annotate_Type_Definition; + + procedure Annotate_Interface_List_Subtype + (Block_Info: Sim_Info_Acc; Decl_Chain: Iir) + is + El: Iir; + begin + El := Decl_Chain; + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Signal_Interface_Declaration => + Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (El)); + when Iir_Kind_Variable_Interface_Declaration + | Iir_Kind_Constant_Interface_Declaration + | Iir_Kind_File_Interface_Declaration => + Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (El)); + when others => + Error_Kind ("annotate_interface_list", El); + end case; + El := Get_Chain (El); + end loop; + end Annotate_Interface_List_Subtype; + + procedure Annotate_Create_Interface_List + (Block_Info: Sim_Info_Acc; Decl_Chain: Iir; With_Types : Boolean) + is + Decl : Iir; + N : Object_Slot_Type; + begin + Decl := Decl_Chain; + while Decl /= Null_Iir loop + if With_Types then + Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (Decl)); + end if; + Assert_No_Info (Decl); + case Get_Kind (Decl) is + when Iir_Kind_Signal_Interface_Declaration => + Add_Signal_Info (Block_Info, Decl); + when Iir_Kind_Variable_Interface_Declaration + | Iir_Kind_Constant_Interface_Declaration + | Iir_Kind_File_Interface_Declaration => + Create_Object_Info (Block_Info, Decl); + when others => + Error_Kind ("annotate_create_interface_list", Decl); + end case; + N := Block_Info.Nbr_Objects; + -- Annotation of the default value must not create objects. + -- FIXME: Is it true ??? + if Block_Info.Nbr_Objects /= N then + raise Internal_Error; + end if; + Decl := Get_Chain (Decl); + end loop; + end Annotate_Create_Interface_List; + + procedure Annotate_Subprogram_Interfaces_Type + (Block_Info : Sim_Info_Acc; Subprg: Iir) + is + Interfaces : constant Iir := Get_Interface_Declaration_Chain (Subprg); + begin + -- See LRM93 12.3.1.1 (Subprogram declarations and bodies). The type + -- of the interfaces are elaborated in the outer context. + Annotate_Interface_List_Subtype (Block_Info, Interfaces); + + if Get_Kind (Subprg) in Iir_Kinds_Function_Declaration then + -- FIXME: can this create a new annotation ? + Annotate_Anonymous_Type_Definition + (Block_Info, Get_Return_Type (Subprg)); + end if; + end Annotate_Subprogram_Interfaces_Type; + + procedure Annotate_Subprogram_Specification + (Block_Info : Sim_Info_Acc; Subprg: Iir) + is + pragma Unreferenced (Block_Info); + Subprg_Info: Sim_Info_Acc; + Interfaces : constant Iir := Get_Interface_Declaration_Chain (Subprg); + Prev_Scope_Level : constant Scope_Level_Type := Current_Scope_Level; + begin + Increment_Current_Scope_Level; + + Assert_No_Info (Subprg); + + Subprg_Info := + new Sim_Info_Type'(Kind => Kind_Frame, + Inst_Slot => 0, + Frame_Scope_Level => Current_Scope_Level, + Nbr_Objects => 0, + Nbr_Instances => 0); + Set_Info (Subprg, Subprg_Info); + + Annotate_Create_Interface_List (Subprg_Info, Interfaces, False); + + Current_Scope_Level := Prev_Scope_Level; + end Annotate_Subprogram_Specification; + + procedure Annotate_Subprogram_Body + (Block_Info : Sim_Info_Acc; Subprg: Iir) + is + pragma Unreferenced (Block_Info); + Spec : constant Iir := Get_Subprogram_Specification (Subprg); + Subprg_Info : constant Sim_Info_Acc := Get_Info (Spec); + Prev_Scope_Level : constant Scope_Level_Type := Current_Scope_Level; + begin + -- Do not annotate body of foreign subprograms. + if Get_Foreign_Flag (Spec) then + return; + end if; + + Current_Scope_Level := Subprg_Info.Frame_Scope_Level; + + Annotate_Declaration_List + (Subprg_Info, Get_Declaration_Chain (Subprg)); + + Annotate_Sequential_Statement_Chain + (Subprg_Info, Get_Sequential_Statement_Chain (Subprg)); + + Current_Scope_Level := Prev_Scope_Level; + end Annotate_Subprogram_Body; + + procedure Annotate_Component_Declaration + (Comp: Iir_Component_Declaration) + is + Info: Sim_Info_Acc; + Prev_Scope_Level : Scope_Level_Type; + begin + Prev_Scope_Level := Current_Scope_Level; + Current_Scope_Level := Scope_Level_Component; + + Assert_No_Info (Comp); + + Info := new Sim_Info_Type'(Kind => Kind_Frame, + Inst_Slot => Invalid_Instance_Slot, + Frame_Scope_Level => Current_Scope_Level, + Nbr_Objects => 0, + Nbr_Instances => 1); -- For the instance. + Set_Info (Comp, Info); + + Annotate_Create_Interface_List (Info, Get_Generic_Chain (Comp), True); + Annotate_Create_Interface_List (Info, Get_Port_Chain (Comp), True); + + Current_Scope_Level := Prev_Scope_Level; + end Annotate_Component_Declaration; + + procedure Annotate_Declaration (Block_Info: Sim_Info_Acc; Decl: Iir) is + begin + case Get_Kind (Decl) is + when Iir_Kind_Delayed_Attribute + | Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Transaction_Attribute + | Iir_Kind_Signal_Declaration => + Assert_No_Info (Decl); + Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (Decl)); + Add_Signal_Info (Block_Info, Decl); + + when Iir_Kind_Variable_Declaration + | Iir_Kind_Iterator_Declaration => + Assert_No_Info (Decl); + Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (Decl)); + Create_Object_Info (Block_Info, Decl); + + when Iir_Kind_Constant_Declaration => + if Get_Deferred_Declaration (Decl) = Null_Iir + or else Get_Deferred_Declaration_Flag (Decl) + then + -- Create the slot only if the constant is not a full constant + -- declaration. + Assert_No_Info (Decl); + Annotate_Anonymous_Type_Definition + (Block_Info, Get_Type (Decl)); + Create_Object_Info (Block_Info, Decl); + else + Set_Info (Decl, Get_Info (Get_Deferred_Declaration (Decl))); + end if; + + when Iir_Kind_File_Declaration => + Assert_No_Info (Decl); + Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (Decl)); + Create_Object_Info (Block_Info, Decl, Kind_File); + + when Iir_Kind_Terminal_Declaration => + Assert_No_Info (Decl); + Add_Terminal_Info (Block_Info, Decl); + when Iir_Kinds_Branch_Quantity_Declaration => + Assert_No_Info (Decl); + Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (Decl)); + Add_Quantity_Info (Block_Info, Decl); + + when Iir_Kind_Type_Declaration + | Iir_Kind_Anonymous_Type_Declaration => + Annotate_Type_Definition (Block_Info, Get_Type_Definition (Decl)); + when Iir_Kind_Subtype_Declaration => + Annotate_Type_Definition (Block_Info, Get_Type (Decl)); + + when Iir_Kind_Protected_Type_Body => + Annotate_Protected_Type_Body (Block_Info, Decl); + + when Iir_Kind_Component_Declaration => + Annotate_Component_Declaration (Decl); + + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + if not Is_Second_Subprogram_Specification (Decl) then + Annotate_Subprogram_Interfaces_Type (Block_Info, Decl); + Annotate_Subprogram_Specification (Block_Info, Decl); + end if; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + Annotate_Subprogram_Body (Block_Info, Decl); + + when Iir_Kind_Object_Alias_Declaration => + Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (Decl)); + Create_Object_Info (Block_Info, Decl); + + when Iir_Kind_Non_Object_Alias_Declaration => + null; + + when Iir_Kind_Attribute_Declaration => + null; + when Iir_Kind_Attribute_Specification => + declare + Value : Iir_Attribute_Value; + begin + Value := Get_Attribute_Value_Spec_Chain (Decl); + while Value /= Null_Iir loop + Create_Object_Info (Block_Info, Value); + Value := Get_Spec_Chain (Value); + end loop; + end; + when Iir_Kind_Disconnection_Specification => + null; + + when Iir_Kind_Implicit_Procedure_Declaration => + null; + when Iir_Kind_Group_Template_Declaration => + null; + when Iir_Kind_Group_Declaration => + null; + when Iir_Kind_Use_Clause => + null; + + when Iir_Kind_Configuration_Specification => + null; + +-- when Iir_Kind_Implicit_Signal_Declaration => +-- declare +-- Nsig : Iir; +-- begin +-- Nsig := Decl; +-- loop +-- Nsig := Get_Implicit_Signal_Chain (Nsig); +-- exit when Nsig = Null_Iir; +-- Add_Signal_Info (Block_Info, Nsig); +-- end loop; +-- end; + + when Iir_Kind_Implicit_Function_Declaration => + null; + + when Iir_Kind_Nature_Declaration => + null; + + when others => + Error_Kind ("annotate_declaration", Decl); + end case; + end Annotate_Declaration; + + procedure Annotate_Declaration_List + (Block_Info: Sim_Info_Acc; Decl_Chain: Iir) + is + El: Iir; + begin + El := Decl_Chain; + while El /= Null_Iir loop + Annotate_Declaration (Block_Info, El); + El := Get_Chain (El); + end loop; + end Annotate_Declaration_List; + + procedure Annotate_Sequential_Statement_Chain + (Block_Info: Sim_Info_Acc; Stmt_Chain: Iir) + is + El: Iir; + Max_Nbr_Objects : Object_Slot_Type; + Current_Nbr_Objects : Object_Slot_Type; + + procedure Save_Nbr_Objects is + begin + -- Objects used by loop statements can be reused later by + -- other (ie following) loop statements. + -- Furthermore, this allow to correctly check elaboration + -- order. + Max_Nbr_Objects := Object_Slot_Type'Max + (Block_Info.Nbr_Objects, Max_Nbr_Objects); + Block_Info.Nbr_Objects := Current_Nbr_Objects; + end Save_Nbr_Objects; + begin + Current_Nbr_Objects := Block_Info.Nbr_Objects; + Max_Nbr_Objects := Current_Nbr_Objects; + + El := Stmt_Chain; + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Null_Statement => + null; + when Iir_Kind_Assertion_Statement + | Iir_Kind_Report_Statement => + null; + when Iir_Kind_Return_Statement => + null; + when Iir_Kind_Signal_Assignment_Statement + | Iir_Kind_Variable_Assignment_Statement => + null; + when Iir_Kind_Procedure_Call_Statement => + null; + when Iir_Kind_Exit_Statement + | Iir_Kind_Next_Statement => + null; + when Iir_Kind_Wait_Statement => + null; + + when Iir_Kind_If_Statement => + declare + Clause: Iir := El; + begin + loop + Annotate_Sequential_Statement_Chain + (Block_Info, Get_Sequential_Statement_Chain (Clause)); + Clause := Get_Else_Clause (Clause); + exit when Clause = Null_Iir; + Save_Nbr_Objects; + end loop; + end; + + when Iir_Kind_Case_Statement => + declare + Assoc: Iir; + begin + Assoc := Get_Case_Statement_Alternative_Chain (El); + loop + Annotate_Sequential_Statement_Chain + (Block_Info, Get_Associated_Chain (Assoc)); + Assoc := Get_Chain (Assoc); + exit when Assoc = Null_Iir; + Save_Nbr_Objects; + end loop; + end; + + when Iir_Kind_For_Loop_Statement => + Annotate_Declaration + (Block_Info, Get_Parameter_Specification (El)); + Annotate_Sequential_Statement_Chain + (Block_Info, Get_Sequential_Statement_Chain (El)); + + when Iir_Kind_While_Loop_Statement => + Annotate_Sequential_Statement_Chain + (Block_Info, Get_Sequential_Statement_Chain (El)); + + when others => + Error_Kind ("annotate_sequential_statement_chain", El); + end case; + + Save_Nbr_Objects; + + El := Get_Chain (El); + end loop; + Block_Info.Nbr_Objects := Max_Nbr_Objects; + end Annotate_Sequential_Statement_Chain; + + procedure Annotate_Block_Statement + (Block_Info : Sim_Info_Acc; Block : Iir_Block_Statement) + is + Info : Sim_Info_Acc; + Header : Iir_Block_Header; + Guard : Iir; + begin + Assert_No_Info (Block); + + Increment_Current_Scope_Level; + + Info := new Sim_Info_Type'(Kind => Kind_Block, + Inst_Slot => Block_Info.Nbr_Instances, + Frame_Scope_Level => Current_Scope_Level, + Nbr_Objects => 0, + Nbr_Instances => 0); + Set_Info (Block, Info); + + Block_Info.Nbr_Instances := Block_Info.Nbr_Instances + 1; + + Guard := Get_Guard_Decl (Block); + if Guard /= Null_Iir then + Add_Signal_Info (Info, Guard); + end if; + Header := Get_Block_Header (Block); + if Header /= Null_Iir then + Annotate_Create_Interface_List + (Info, Get_Generic_Chain (Header), True); + Annotate_Create_Interface_List + (Info, Get_Port_Chain (Header), True); + end if; + Annotate_Declaration_List (Info, Get_Declaration_Chain (Block)); + Annotate_Concurrent_Statements_List + (Info, Get_Concurrent_Statement_Chain (Block)); + + Current_Scope_Level := Current_Scope_Level - 1; + end Annotate_Block_Statement; + + procedure Annotate_Generate_Statement + (Block_Info : Sim_Info_Acc; Stmt : Iir) + is + Info : Sim_Info_Acc; + Scheme : constant Iir := Get_Generation_Scheme (Stmt); + Is_Iterative : constant Boolean := + Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration; + begin + Assert_No_Info (Stmt); + + Increment_Current_Scope_Level; + + Info := new Sim_Info_Type'(Kind => Kind_Block, + Inst_Slot => Block_Info.Nbr_Instances, + Frame_Scope_Level => Current_Scope_Level, + Nbr_Objects => 0, + Nbr_Instances => 0); + Set_Info (Stmt, Info); + + Block_Info.Nbr_Instances := Block_Info.Nbr_Instances + 1; + + if Is_Iterative then + Annotate_Declaration (Info, Scheme); + end if; + Annotate_Declaration_List (Info, Get_Declaration_Chain (Stmt)); + Annotate_Concurrent_Statements_List + (Info, Get_Concurrent_Statement_Chain (Stmt)); + + Current_Scope_Level := Current_Scope_Level - 1; + end Annotate_Generate_Statement; + + procedure Annotate_Component_Instantiation_Statement + (Block_Info : Sim_Info_Acc; Stmt : Iir) + is + Info: Sim_Info_Acc; + begin + -- Add a slot just to put the instance. + Assert_No_Info (Stmt); + Info := new Sim_Info_Type'(Kind => Kind_Block, + Inst_Slot => Block_Info.Nbr_Instances, + Frame_Scope_Level => Current_Scope_Level + 1, + Nbr_Objects => 0, + Nbr_Instances => 1); + Set_Info (Stmt, Info); + Block_Info.Nbr_Instances := Block_Info.Nbr_Instances + 1; + end Annotate_Component_Instantiation_Statement; + + procedure Annotate_Process_Statement (Block_Info : Sim_Info_Acc; Stmt : Iir) + is + pragma Unreferenced (Block_Info); + Info: Sim_Info_Acc; + begin + Increment_Current_Scope_Level; + + -- Add a slot just to put the instance. + Assert_No_Info (Stmt); + + Info := new Sim_Info_Type'(Kind => Kind_Process, + Inst_Slot => Invalid_Instance_Slot, + Frame_Scope_Level => Current_Scope_Level, + Nbr_Objects => 0, + Nbr_Instances => 0); + Set_Info (Stmt, Info); + + Annotate_Declaration_List + (Info, Get_Declaration_Chain (Stmt)); + Annotate_Sequential_Statement_Chain + (Info, Get_Sequential_Statement_Chain (Stmt)); + + Current_Scope_Level := Current_Scope_Level - 1; + end Annotate_Process_Statement; + + procedure Annotate_Concurrent_Statements_List + (Block_Info: Sim_Info_Acc; Stmt_Chain : Iir) + is + El: Iir; + begin + El := Stmt_Chain; + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement => + Annotate_Process_Statement (Block_Info, El); + + when Iir_Kind_Component_Instantiation_Statement => + Annotate_Component_Instantiation_Statement (Block_Info, El); + + when Iir_Kind_Block_Statement => + Annotate_Block_Statement (Block_Info, El); + + when Iir_Kind_Generate_Statement => + Annotate_Generate_Statement (Block_Info, El); + + when Iir_Kind_Simple_Simultaneous_Statement => + null; + + when others => + Error_Kind ("annotate_concurrent_statements_list", El); + end case; + El := Get_Chain (El); + end loop; + end Annotate_Concurrent_Statements_List; + + procedure Annotate_Entity (Decl: Iir_Entity_Declaration) is + Entity_Info: Sim_Info_Acc; + begin + Assert_No_Info (Decl); + + Current_Scope_Level := Scope_Level_Entity; + + Entity_Info := + new Sim_Info_Type'(Kind => Kind_Block, + Inst_Slot => Invalid_Instance_Slot, + Frame_Scope_Level => Current_Scope_Level, + Nbr_Objects => 0, + Nbr_Instances => 0); + Set_Info (Decl, Entity_Info); + + -- generic list. + Annotate_Create_Interface_List + (Entity_Info, Get_Generic_Chain (Decl), True); + + -- Port list. + Annotate_Create_Interface_List + (Entity_Info, Get_Port_Chain (Decl), True); + + -- declarations + Annotate_Declaration_List (Entity_Info, Get_Declaration_Chain (Decl)); + + -- processes. + Annotate_Concurrent_Statements_List + (Entity_Info, Get_Concurrent_Statement_Chain (Decl)); + end Annotate_Entity; + + procedure Annotate_Architecture (Decl: Iir_Architecture_Body) + is + Entity_Info: Sim_Info_Acc; + Arch_Info: Sim_Info_Acc; + begin + Assert_No_Info (Decl); + + Current_Scope_Level := Scope_Level_Entity; + + Entity_Info := Get_Info (Get_Entity (Decl)); + + Arch_Info := new Sim_Info_Type' + (Kind => Kind_Block, + Inst_Slot => 0, -- Slot for a component + Frame_Scope_Level => Current_Scope_Level, + Nbr_Objects => Entity_Info.Nbr_Objects, + Nbr_Instances => Entity_Info.Nbr_Instances); -- Should be 0. + Set_Info (Decl, Arch_Info); + + -- FIXME: annotate the default configuration for the arch ? + + -- declarations + Annotate_Declaration_List (Arch_Info, Get_Declaration_Chain (Decl)); + + -- processes. + Annotate_Concurrent_Statements_List + (Arch_Info, Get_Concurrent_Statement_Chain (Decl)); + end Annotate_Architecture; + + procedure Annotate_Package (Decl: Iir_Package_Declaration) is + Package_Info: Sim_Info_Acc; + begin + Assert_No_Info (Decl); + + Nbr_Packages := Nbr_Packages + 1; + Current_Scope_Level := Scope_Level_Type (-Nbr_Packages); + + Package_Info := new Sim_Info_Type' + (Kind => Kind_Block, + Inst_Slot => Instance_Slot_Type (Nbr_Packages), + Frame_Scope_Level => Current_Scope_Level, + Nbr_Objects => 0, + Nbr_Instances => 0); + + Set_Info (Decl, Package_Info); + + -- declarations + Annotate_Declaration_List (Package_Info, Get_Declaration_Chain (Decl)); + + Current_Scope_Level := Scope_Level_Global; + end Annotate_Package; + + procedure Annotate_Package_Body (Decl: Iir) + is + Package_Info: Sim_Info_Acc; + begin + Assert_No_Info (Decl); + + -- Set info field of package body declaration. + Package_Info := Get_Info (Get_Package (Decl)); + Set_Info (Decl, Package_Info); + + Current_Scope_Level := Package_Info.Frame_Scope_Level; + + -- declarations + Annotate_Declaration_List (Package_Info, Get_Declaration_Chain (Decl)); + end Annotate_Package_Body; + + procedure Annotate_Component_Configuration + (Conf : Iir_Component_Configuration) + is + Block : constant Iir := Get_Block_Configuration (Conf); + begin + Annotate_Block_Configuration (Block); + end Annotate_Component_Configuration; + + procedure Annotate_Block_Configuration (Block : Iir_Block_Configuration) + is + El : Iir; + begin + if Block = Null_Iir then + return; + end if; + Assert_No_Info (Block); + + -- Declaration are use_clause only. + El := Get_Configuration_Item_Chain (Block); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Block_Configuration => + Annotate_Block_Configuration (El); + when Iir_Kind_Component_Configuration => + Annotate_Component_Configuration (El); + when others => + Error_Kind ("annotate_block_configuration", El); + end case; + El := Get_Chain (El); + end loop; + end Annotate_Block_Configuration; + + procedure Annotate_Configuration_Declaration + (Decl : Iir_Configuration_Declaration) + is + Config_Info: Sim_Info_Acc; + begin + Assert_No_Info (Decl); + + Config_Info := new Sim_Info_Type' + (Kind => Kind_Block, + Inst_Slot => Invalid_Instance_Slot, + Frame_Scope_Level => Scope_Level_Global, + Nbr_Objects => 0, + Nbr_Instances => 0); + + Current_Scope_Level := Scope_Level_Global; + + Annotate_Declaration_List (Config_Info, Get_Declaration_Chain (Decl)); + Annotate_Block_Configuration (Get_Block_Configuration (Decl)); + end Annotate_Configuration_Declaration; + + package Info_Node is new GNAT.Table + (Table_Component_Type => Sim_Info_Acc, + Table_Index_Type => Iir, + Table_Low_Bound => 2, + Table_Initial => 1024, + Table_Increment => 100); + + procedure Annotate_Expand_Table + is + El: Iir; + begin + Info_Node.Increment_Last; + El := Info_Node.Last; + Info_Node.Set_Last (Get_Last_Node); + for I in El .. Info_Node.Last loop + Info_Node.Table (I) := null; + end loop; + end Annotate_Expand_Table; + + -- Decorate the tree in order to be usable with the internal simulator. + procedure Annotate (Tree: Iir_Design_Unit) + is + El: Iir; + begin + -- Expand info table. + Annotate_Expand_Table; + + El := Get_Library_Unit (Tree); + if Trace_Annotation then + Ada.Text_IO.Put_Line ("annotating " & Disp_Node (El)); + end if; + case Get_Kind (El) is + when Iir_Kind_Entity_Declaration => + Annotate_Entity (El); + when Iir_Kind_Architecture_Body => + Annotate_Architecture (El); + when Iir_Kind_Package_Declaration => + Annotate_Package (El); + declare + use Std_Package; + begin + if El = Standard_Package then + -- These types are not in std.standard! + Annotate_Type_Definition + (Get_Info (El), Convertible_Integer_Type_Definition); + Annotate_Type_Definition + (Get_Info (El), Convertible_Real_Type_Definition); + end if; + end; + when Iir_Kind_Package_Body => + Annotate_Package_Body (El); + when Iir_Kind_Configuration_Declaration => + Annotate_Configuration_Declaration (El); + when others => + Error_Kind ("annotate2", El); + end case; + end Annotate; + + -- Disp annotations for an iir node. + procedure Disp_Vhdl_Info (Node: Iir) is + use Ada.Text_IO; + Indent: Count; + Info: Sim_Info_Acc; + begin + Info := Get_Info (Node); + Indent := Col; + case Info.Kind is + when Kind_Block => + Put_Line + ("-- nbr objects:" & Object_Slot_Type'Image (Info.Nbr_Objects)); + + when Kind_Frame | Kind_Process => + Put_Line ("-- scope level:" & + Scope_Level_Type'Image (Info.Frame_Scope_Level)); + Set_Col (Indent); + Put_Line + ("-- nbr objects:" & Object_Slot_Type'Image (Info.Nbr_Objects)); + + when Kind_Object | Kind_Signal | Kind_File + | Kind_Terminal | Kind_Quantity => + Put_Line ("-- slot:" & Object_Slot_Type'Image (Info.Slot) + & ", scope:" + & Scope_Level_Type'Image (Info.Scope_Level)); + when Kind_Scalar_Type + | Kind_File_Type => + null; + when Kind_Range => + Put ("${"); + Put (Object_Slot_Type'Image (Info.Slot)); + Put ("}"); + end case; + end Disp_Vhdl_Info; + + procedure Disp_Info (Info : Sim_Info_Acc) + is + use Ada.Text_IO; + Indent: Count; + begin + Indent := Col + 2; + Set_Col (Indent); + if Info = null then + Put_Line ("*null*"); + return; + end if; + case Info.Kind is + when Kind_Block | Kind_Frame | Kind_Process => + Put_Line ("scope level:" & + Scope_Level_Type'Image (Info.Frame_Scope_Level)); + Set_Col (Indent); + Put_Line ("inst_slot:" + & Instance_Slot_Type'Image (Info.Inst_Slot)); + Set_Col (Indent); + Put_Line ("nbr objects:" + & Object_Slot_Type'Image (Info.Nbr_Objects)); + Set_Col (Indent); + Put_Line ("nbr instance:" + & Instance_Slot_Type'Image (Info.Nbr_Instances)); + when Kind_Object | Kind_Signal | Kind_File + | Kind_Terminal | Kind_Quantity => + Put_Line ("slot:" & Object_Slot_Type'Image (Info.Slot) + & ", scope:" + & Scope_Level_Type'Image (Info.Scope_Level)); + when Kind_Range => + Put_Line ("range slot:" & Object_Slot_Type'Image (Info.Slot)); + when Kind_Scalar_Type => + Put_Line ("scalar type: " + & Iir_Value_Kind'Image (Info.Scalar_Mode)); + when Kind_File_Type => + Put ("file type: "); + if Info.File_Signature = null then + Put ("(no sig)"); + else + Put (Info.File_Signature.all); + end if; + New_Line; + end case; + end Disp_Info; + + procedure Disp_Tree_Info (Node: Iir) is + begin + Disp_Info (Get_Info (Node)); + end Disp_Tree_Info; + + procedure Set_Info (Target: Iir; Info: Sim_Info_Acc) is + begin + Info_Node.Table (Target) := Info; + end Set_Info; + + function Get_Info (Target: Iir) return Sim_Info_Acc is + begin + return Info_Node.Table (Target); + end Get_Info; +end Annotations; diff --git a/src/simulate/annotations.ads b/src/simulate/annotations.ads new file mode 100644 index 000000000..e9b48d005 --- /dev/null +++ b/src/simulate/annotations.ads @@ -0,0 +1,120 @@ +-- Annotations for interpreted simulation +-- Copyright (C) 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 GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Iirs; use Iirs; +with Iir_Values; use Iir_Values; +with Types; use Types; + +package Annotations is + Trace_Annotation : Boolean := False; + + -- Decorate the tree in order to be usable with the internal simulator. + procedure Annotate (Tree: Iir_Design_Unit); + + -- Disp annotations for an iir node. + procedure Disp_Vhdl_Info (Node: Iir); + procedure Disp_Tree_Info (Node: Iir); + + -- Annotations are used to collect informations for elaboration and to + -- locate iir_value_literal for signals, variables or constants. + + -- Scope corresponding to an object. + -- Scope_level_global is for objects that can be instancied only one + -- time, ie shared signals or constants declared in a package. + -- + -- Scope_Level_Process is for objects declared in an entity, architecture, + -- process, bloc (but not generated bloc). These are static objects, that + -- can be instancied several times. + -- + -- Scope_Level_First_Function and above are for dynamic objects declared + -- in a subprogram. The level is also the nest level. + -- + -- Scope_Level_Component is set to a maximum, since there is at + -- most one scope after it (the next one is an entity). + type Scope_Level_Type is new Integer; + Scope_Level_Global: constant Scope_Level_Type := 0; + Scope_Level_Entity: constant Scope_Level_Type := 1; + Scope_Level_Component : constant Scope_Level_Type := + Scope_Level_Type'Last - 1; + + type Instance_Slot_Type is new Integer; + Invalid_Instance_Slot : constant Instance_Slot_Type := -1; + + type Object_Slot_Type is new Integer; + + -- The annotation depends on the kind of the node. + type Sim_Info_Kind is + (Kind_Block, Kind_Process, Kind_Frame, + Kind_Scalar_Type, Kind_File_Type, + Kind_Object, Kind_Signal, Kind_Range, + Kind_File, + Kind_Terminal, Kind_Quantity); + + type Sim_Info_Type (Kind: Sim_Info_Kind); + type Sim_Info_Acc is access all Sim_Info_Type; + + -- Annotation for an iir node in order to be able to simulate it. + type Sim_Info_Type (Kind: Sim_Info_Kind) is record + case Kind is + when Kind_Block + | Kind_Frame + | Kind_Process => + -- Slot number. + Inst_Slot : Instance_Slot_Type; + + -- scope level for this frame. + Frame_Scope_Level: Scope_Level_Type; + + -- Number of objects/signals. + Nbr_Objects : Object_Slot_Type; + + -- Number of children (blocks, generate, instantiation). + Nbr_Instances : Instance_Slot_Type; + + when Kind_Object + | Kind_Signal + | Kind_Range + | Kind_File + | Kind_Terminal + | Kind_Quantity => + -- block considered (hierarchy). + Scope_Level: Scope_Level_Type; + + -- Variable index. + Slot: Object_Slot_Type; + + when Kind_Scalar_Type => + Scalar_Mode : Iir_Value_Kind; + + when Kind_File_Type => + File_Signature : String_Acc; + end case; + end record; + + Nbr_Packages : Iir_Index32 := 0; + + -- Get/Set annotation fied from/to an iir. + procedure Set_Info (Target: Iir; Info: Sim_Info_Acc); + pragma Inline (Set_Info); + function Get_Info (Target: Iir) return Sim_Info_Acc; + pragma Inline (Get_Info); + + -- Expand the annotation table. This is automatically done by Annotate, + -- to be used only by debugger. + procedure Annotate_Expand_Table; +end Annotations; diff --git a/src/simulate/areapools.adb b/src/simulate/areapools.adb new file mode 100644 index 000000000..341b14240 --- /dev/null +++ b/src/simulate/areapools.adb @@ -0,0 +1,147 @@ +-- Area based memory manager +-- Copyright (C) 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 GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Ada.Unchecked_Deallocation; + +package body Areapools is + procedure Deallocate is new Ada.Unchecked_Deallocation + (Chunk_Type, Chunk_Acc); + + Free_Chunks : Chunk_Acc; + + function Get_Chunk return Chunk_Acc is + Res : Chunk_Acc; + begin + if Free_Chunks /= null then + Res := Free_Chunks; + Free_Chunks := Res.Prev; + return Res; + else + return new Chunk_Type (Default_Chunk_Size - 1); + end if; + end Get_Chunk; + + procedure Free_Chunk (Chunk : Chunk_Acc) is + begin + Chunk.Prev := Free_Chunks; + Free_Chunks := Chunk; + end Free_Chunk; + + procedure Allocate (Pool : in out Areapool; + Res : out Address; + Size : Size_Type; + Align : Size_Type) + is + Align_M1 : constant Size_Type := Align - 1; + + function Do_Align (X : Size_Type) return Size_Type is + begin + return (X + Align_M1) and not Align_M1; + end Do_Align; + + Chunk : Chunk_Acc; + begin + -- Need to allocate a new chunk if there is no current chunk, or not + -- enough room in the current chunk. + if Pool.Last = null + or else Do_Align (Pool.Next_Use) + Size > Pool.Last.Last + then + if Size > Default_Chunk_Size then + Chunk := new Chunk_Type (Size - 1); + else + Chunk := Get_Chunk; + end if; + Chunk.Prev := Pool.Last; + Pool.Next_Use := 0; + if Pool.First = null then + Pool.First := Chunk; + end if; + Pool.Last := Chunk; + else + Chunk := Pool.Last; + Pool.Next_Use := Do_Align (Pool.Next_Use); + end if; + Res := Chunk.Data (Pool.Next_Use)'Address; + Pool.Next_Use := Pool.Next_Use + Size; + end Allocate; + + procedure Mark (M : out Mark_Type; Pool : Areapool) is + begin + M := (Last => Pool.Last, Next_Use => Pool.Next_Use); + end Mark; + + procedure Release (M : Mark_Type; Pool : in out Areapool) + is + Chunk : Chunk_Acc; + Prev : Chunk_Acc; + begin + Chunk := Pool.Last; + while Chunk /= M.Last loop + if Erase_When_Released then + Chunk.Data := (others => 16#DE#); + end if; + + Prev := Chunk.Prev; + if Chunk.Last = Default_Chunk_Size - 1 then + Free_Chunk (Chunk); + else + Deallocate (Chunk); + end if; + Chunk := Prev; + end loop; + + if Erase_When_Released + and then M.Last /= null + then + declare + Last : Size_Type; + begin + if Pool.Last = M.Last then + Last := Pool.Next_Use - 1; + else + Last := Chunk.Data'Last; + end if; + Chunk.Data (M.Next_Use .. Last) := (others => 16#DE#); + end; + end if; + + Pool.Last := M.Last; + Pool.Next_Use := M.Next_Use; + end Release; + + function Is_Empty (Pool : Areapool) return Boolean is + begin + return Pool.Last = null; + end Is_Empty; + + function Alloc_On_Pool_Addr (Pool : Areapool_Acc; Val : T) + return System.Address + is + Res : Address; + begin + Allocate (Pool.all, Res, T'Size / Storage_Unit, T'Alignment); + declare + Addr1 : constant Address := Res; + Init : T := Val; + for Init'Address use Addr1; + begin + null; + end; + return Res; + end Alloc_On_Pool_Addr; +end Areapools; diff --git a/src/simulate/areapools.ads b/src/simulate/areapools.ads new file mode 100644 index 000000000..186f29707 --- /dev/null +++ b/src/simulate/areapools.ads @@ -0,0 +1,87 @@ +-- Area based memory manager +-- Copyright (C) 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 GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with System; use System; +with System.Storage_Elements; use System.Storage_Elements; + +package Areapools is + type Areapool is limited private; + type Mark_Type is private; + + type Areapool_Acc is access all Areapool; + + -- Modular type for the size. We don't use Storage_Offset in order to + -- make alignment computation efficient (knowing that alignment is a + -- power of two). + type Size_Type is mod System.Memory_Size; + + -- Allocate SIZE bytes (aligned on ALIGN bytes) in memory pool POOL and + -- return the address in RES. + procedure Allocate (Pool : in out Areapool; + Res : out Address; + Size : Size_Type; + Align : Size_Type); + + -- Return TRUE iff no memory is allocated in POOL. + function Is_Empty (Pool : Areapool) return Boolean; + + -- Higher level abstraction for Allocate. + generic + type T is private; + function Alloc_On_Pool_Addr (Pool : Areapool_Acc; Val : T) + return System.Address; + + -- Get a mark of POOL. + procedure Mark (M : out Mark_Type; + Pool : Areapool); + + -- Release memory allocated in POOL after mark M. + procedure Release (M : Mark_Type; + Pool : in out Areapool); + + Empty_Marker : constant Mark_Type; +private + -- Minimal size of allocation. + Default_Chunk_Size : constant Size_Type := 16 * 1024; + + type Chunk_Type; + type Chunk_Acc is access all Chunk_Type; + + type Data_Array is array (Size_Type range <>) of Storage_Element; + for Data_Array'Alignment use Standard'Maximum_Alignment; + + type Chunk_Type (Last : Size_Type) is record + Prev : Chunk_Acc; + Data : Data_Array (0 .. Last); + end record; + for Chunk_Type'Alignment use Standard'Maximum_Alignment; + + type Areapool is limited record + First, Last : Chunk_Acc := null; + Next_Use : Size_Type; + end record; + + type Mark_Type is record + Last : Chunk_Acc := null; + Next_Use : Size_Type; + end record; + + Empty_Marker : constant Mark_Type := (Last => null, Next_Use => 0); + + Erase_When_Released : constant Boolean := True; +end Areapools; diff --git a/src/simulate/debugger.adb b/src/simulate/debugger.adb new file mode 100644 index 000000000..5a43533d6 --- /dev/null +++ b/src/simulate/debugger.adb @@ -0,0 +1,1845 @@ +-- Debugger for interpreter +-- Copyright (C) 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 GHDL; 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 Ada.Text_IO; use Ada.Text_IO; +with GNAT.Table; +with Types; use Types; +with Iir_Values; use Iir_Values; +with Name_Table; +with Files_Map; +with Parse; +with Scanner; +with Tokens; +with Sem_Expr; +with Sem_Scopes; +with Std_Names; +with Libraries; +with Std_Package; +with Annotations; use Annotations; +with Iirs_Utils; use Iirs_Utils; +with Errorout; use Errorout; +with Disp_Vhdl; +with Execution; use Execution; +with Simulation; use Simulation; +with Iirs_Walk; use Iirs_Walk; +with Areapools; use Areapools; +with Grt.Disp; +with Grt.Readline; +with Grt.Errors; +with Grt.Disp_Signals; + +package body Debugger is + -- This exception can be raised by a debugger command to directly return + -- to the prompt. + Command_Error : exception; + + Dbg_Top_Frame : Block_Instance_Acc; + Dbg_Cur_Frame : Block_Instance_Acc; + + procedure Set_Cur_Frame (Frame : Block_Instance_Acc) is + begin + Dbg_Cur_Frame := Frame; + end Set_Cur_Frame; + + procedure Set_Top_Frame (Frame : Block_Instance_Acc) is + begin + Dbg_Top_Frame := Frame; + Set_Cur_Frame (Frame); + end Set_Top_Frame; + + type Breakpoint_Entry is record + Stmt : Iir; + end record; + + package Breakpoints is new GNAT.Table + (Table_Index_Type => Natural, + Table_Component_Type => Breakpoint_Entry, + Table_Low_Bound => 1, + Table_Initial => 16, + Table_Increment => 100); + + -- Current execution state, or reason to stop execution (set by the + -- last debugger command). + type Exec_State_Type is + (-- Execution should continue until a breakpoint is reached or assertion + -- failure. + Exec_Run, + + -- Execution will stop at the next statement. + Exec_Single_Step, + + -- Execution will stop at the next statement in the same frame. + Exec_Next); + + Exec_State : Exec_State_Type := Exec_Run; + + Exec_Instance : Block_Instance_Acc; + + -- Disp a message during execution. + procedure Error_Msg_Exec (Msg: String; Loc: in Iir) is + begin + Disp_Iir_Location (Loc); + Put (Standard_Error, ' '); + Put_Line (Standard_Error, Msg); + Grt.Errors.Fatal_Error; + end Error_Msg_Exec; + + procedure Warning_Msg_Exec (Msg: String; Loc: Iir) is + begin + Disp_Iir_Location (Loc); + Put (Standard_Error, "warning: "); + Put_Line (Standard_Error, Msg); + end Warning_Msg_Exec; + + -- Disp a message for a constraint error. + procedure Error_Msg_Constraint (Expr: in Iir) is + begin + if Expr /= Null_Iir then + Disp_Iir_Location (Expr); + end if; + Put (Standard_Error, "constraint violation"); + if Expr /= Null_Iir then + case Get_Kind (Expr) is + when Iir_Kind_Addition_Operator => + Put_Line (Standard_Error, " in the ""+"" operation"); + when Iir_Kind_Substraction_Operator => + Put_Line (Standard_Error, " in the ""-"" operation"); + when Iir_Kind_Integer_Literal => + Put_Line (Standard_Error, ", literal out of range"); + when Iir_Kind_Signal_Interface_Declaration + | Iir_Kind_Signal_Declaration => + Put_Line (Standard_Error, " for " & Disp_Node (Expr)); + when others => + New_Line (Standard_Error); + end case; + end if; + Grt.Errors.Fatal_Error; + end Error_Msg_Constraint; + + function Get_Instance_Local_Name (Instance : Block_Instance_Acc; + Short : Boolean := False) + return String + is + Name : constant Iir := Instance.Label; + begin + if Name = Null_Iir then + return "<anon>"; + end if; + + case Get_Kind (Name) is + when Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement + | Iir_Kind_Component_Instantiation_Statement + | Iir_Kind_Procedure_Declaration + | Iir_Kinds_Process_Statement => + return Image_Identifier (Name); + when Iir_Kind_Iterator_Declaration => + return Image_Identifier (Get_Parent (Name)) & '(' + & Execute_Image_Attribute + (Instance.Objects (Get_Info (Name).Slot), Get_Type (Name)) + & ')'; + when Iir_Kind_Architecture_Body => + if Short then + return Image_Identifier (Get_Entity (Name)); + else + return Image_Identifier (Get_Entity (Name)) + & '(' & Image_Identifier (Name) & ')'; + end if; + when others => + Error_Kind ("disp_instance_local_name", Name); + end case; + end Get_Instance_Local_Name; + + -- Disp the name of an instance, without newline. + procedure Disp_Instance_Name (Instance: Block_Instance_Acc; + Short : Boolean := False) is + begin + if Instance.Parent /= null then + Disp_Instance_Name (Instance.Parent); + Put ('.'); + end if; + Put (Get_Instance_Local_Name (Instance, Short)); + end Disp_Instance_Name; + + function Get_Instance_Name (Instance: Block_Instance_Acc) return String + is + function Parent_Name return String is + begin + if Instance.Parent /= null then + return Get_Instance_Name (Instance.Parent) & '.'; + else + return ""; + end if; + end Parent_Name; + begin + return Parent_Name & Get_Instance_Local_Name (Instance); + end Get_Instance_Name; + + procedure Disp_Instances_Tree_Name (Inst : Block_Instance_Acc) is + begin + if Inst = null then + Put ("*null*"); + New_Line; + return; + end if; + Put (Get_Instance_Local_Name (Inst)); + + Put (" "); + case Get_Kind (Inst.Label) is + when Iir_Kind_Block_Statement => + Put ("[block]"); + when Iir_Kind_Generate_Statement => + Put ("[generate]"); + when Iir_Kind_Iterator_Declaration => + Put ("[iterator]"); + when Iir_Kind_Component_Instantiation_Statement => + Put ("[component]"); + when Iir_Kinds_Process_Statement => + Put ("[process]"); + when Iir_Kind_Architecture_Body => + Put ("[entity]"); + when others => + Error_Kind ("disp_instances_tree1", Inst.Label); + end case; + New_Line; + end Disp_Instances_Tree_Name; + + procedure Disp_Instances_Tree1 (Inst : Block_Instance_Acc; Pfx : String) + is + Child : Block_Instance_Acc; + begin + Child := Inst.Children; + if Child = null then + return; + end if; + + loop + if Child.Brother /= null then + Put (Pfx & "+-"); + Disp_Instances_Tree_Name (Child); + + Disp_Instances_Tree1 (Child, Pfx & "| "); + Child := Child.Brother; + else + Put (Pfx & "`-"); + Disp_Instances_Tree_Name (Child); + + Disp_Instances_Tree1 (Child, Pfx & " "); + exit; + end if; + end loop; + end Disp_Instances_Tree1; + + procedure Disp_Instances_Tree is + begin + Disp_Instances_Tree_Name (Top_Instance); + Disp_Instances_Tree1 (Top_Instance, ""); + end Disp_Instances_Tree; + + -- Disp a block instance, in a human readable way. + -- Used to debug. + procedure Disp_Block_Instance (Instance: Block_Instance_Acc) is + begin + Put_Line ("scope level:" + & Scope_Level_Type'Image (Instance.Scope_Level)); + Put_Line ("Objects:"); + for I in Instance.Objects'Range loop + Put (Object_Slot_Type'Image (I) & ": "); + Disp_Value_Tab (Instance.Objects (I), 3); + New_Line; + end loop; + end Disp_Block_Instance; + + procedure Disp_Signal (Value : Iir_Value_Literal_Acc; A_Type : Iir); + + procedure Disp_Signal_Array (Value : Iir_Value_Literal_Acc; + A_Type : Iir; + Dim : Natural) + is + begin + if Dim = Get_Nbr_Elements (Get_Index_Subtype_List (A_Type)) then + Put ("("); + for I in Value.Val_Array.V'Range loop + if I /= 1 then + Put (", "); + end if; + Disp_Signal (Value.Val_Array.V (I), Get_Element_Subtype (A_Type)); + end loop; + Put (")"); + else + Put ("("); + Disp_Signal_Array (Value, A_Type, Dim + 1); + Put (")"); + end if; + end Disp_Signal_Array; + + procedure Disp_Signal_Record (Value : Iir_Value_Literal_Acc; A_Type : Iir) + is + El : Iir_Element_Declaration; + List : Iir_List; + begin + List := Get_Elements_Declaration_List (Get_Base_Type (A_Type)); + Put ("("); + for I in Value.Val_Record.V'Range loop + El := Get_Nth_Element (List, Natural (I - 1)); + if I /= 1 then + Put (", "); + end if; + Put (Name_Table.Image (Get_Identifier (El))); + Put (" => "); + Disp_Signal (Value.Val_Record.V (I), Get_Type (El)); + end loop; + Put (")"); + end Disp_Signal_Record; + + procedure Disp_Signal (Value : Iir_Value_Literal_Acc; A_Type : Iir) is + begin + if Value = null then + Put ("!NULL!"); + return; + end if; + case Value.Kind is + when Iir_Value_I64 + | Iir_Value_F64 + | Iir_Value_E32 + | Iir_Value_B1 + | Iir_Value_Access => + Disp_Iir_Value (Value, A_Type); + when Iir_Value_Array => + Disp_Signal_Array (Value, A_Type, 1); + when Iir_Value_Record => + Disp_Signal_Record (Value, A_Type); + when Iir_Value_Range => + -- FIXME. + raise Internal_Error; + when Iir_Value_Signal => + Grt.Disp_Signals.Disp_A_Signal (Value.Sig); + when Iir_Value_File + | Iir_Value_Protected + | Iir_Value_Quantity + | Iir_Value_Terminal => + raise Internal_Error; + end case; + end Disp_Signal; + + procedure Disp_Instance_Signal (Instance: Block_Instance_Acc; Decl : Iir) + is + Info : constant Sim_Info_Acc := Get_Info (Decl); + begin + Put (" "); + Put (Name_Table.Image (Get_Identifier (Decl))); + Put (" = "); + Disp_Signal (Instance.Objects (Info.Slot), Get_Type (Decl)); + end Disp_Instance_Signal; + + procedure Disp_Instance_Signals_Of_Chain (Instance: Block_Instance_Acc; + Chain : Iir) + is + El : Iir; + begin + El := Chain; + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Signal_Interface_Declaration => + Disp_Instance_Signal (Instance, El); + when others => + null; + end case; + El := Get_Chain (El); + end loop; + end Disp_Instance_Signals_Of_Chain; + + procedure Disp_Instance_Signals (Instance: Block_Instance_Acc) + is + Blk : constant Iir := Instance.Label; + Child: Block_Instance_Acc; + begin + case Get_Kind (Blk) is + when Iir_Kind_Architecture_Body => + declare + Ent : constant Iir := Get_Entity (Blk); + begin + Disp_Instance_Name (Instance); + Put_Line (" [architecture]:"); + + Disp_Instance_Signals_Of_Chain + (Instance, Get_Port_Chain (Ent)); + Disp_Instance_Signals_Of_Chain + (Instance, Get_Declaration_Chain (Ent)); + end; + when Iir_Kind_Block_Statement => + Disp_Instance_Name (Instance); + Put_Line (" [block]:"); + + -- FIXME: ports. + Disp_Instance_Signals_Of_Chain + (Instance, Get_Declaration_Chain (Blk)); + when Iir_Kind_Generate_Statement => + Disp_Instance_Name (Instance); + Put_Line (" [generate]:"); + + Disp_Instance_Signals_Of_Chain + (Instance, Get_Declaration_Chain (Blk)); + when Iir_Kind_Component_Instantiation_Statement => + null; + when Iir_Kinds_Process_Statement => + null; + when Iir_Kind_Iterator_Declaration => + null; + when others => + Error_Kind ("disp_instance_signals", Instance.Label); + end case; + + Child := Instance.Children; + while Child /= null loop + Disp_Instance_Signals (Child); + Child := Child.Brother; + end loop; + end Disp_Instance_Signals; + + -- Disp all signals name and values. + procedure Disp_Signals_Value is + begin + if Disp_Time_Before_Values then + Grt.Disp.Disp_Now; + end if; + Disp_Instance_Signals (Top_Instance); + end Disp_Signals_Value; + + procedure Disp_Objects_Value is + begin + null; +-- -- Disp the results. +-- for I in 0 .. Variables.Last loop +-- Put (Get_String (Variables.Table (I).Name.all)); +-- Put (" = "); +-- Put (Get_Str_Value +-- (Get_Literal (variables.Table (I).Value.all), +-- Get_Type (variables.Table (I).Value.all))); +-- if I = variables.Last then +-- Put_Line (";"); +-- else +-- Put (", "); +-- end if; +-- end loop; + end Disp_Objects_Value; + + procedure Disp_Label (Process : Iir) + is + Label : Name_Id; + begin + Label := Get_Label (Process); + if Label = Null_Identifier then + Put ("<unlabeled>"); + else + Put (Name_Table.Image (Label)); + end if; + end Disp_Label; + + procedure Disp_Declaration_Objects + (Instance : Block_Instance_Acc; Decl_Chain : Iir) + is + El : Iir; + begin + El := Decl_Chain; + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Constant_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Variable_Interface_Declaration + | Iir_Kind_Constant_Interface_Declaration + | Iir_Kind_File_Interface_Declaration + | Iir_Kind_Object_Alias_Declaration => + Put (Disp_Node (El)); + Put (" = "); + Disp_Value_Tab (Instance.Objects (Get_Info (El).Slot), 3); + when Iir_Kind_Signal_Interface_Declaration => + declare + Sig : Iir_Value_Literal_Acc; + begin + Sig := Instance.Objects (Get_Info (El).Slot); + Put (Disp_Node (El)); + Put (" = "); + Disp_Signal (Sig, Get_Type (El)); + New_Line; + end; + when Iir_Kind_Type_Declaration + | Iir_Kind_Anonymous_Type_Declaration + | Iir_Kind_Subtype_Declaration => + -- FIXME: disp ranges + null; + when Iir_Kind_Implicit_Function_Declaration => + null; + when others => + Error_Kind ("disp_declaration_objects", El); + end case; + El := Get_Chain (El); + end loop; + end Disp_Declaration_Objects; + + procedure Disp_Objects (Instance : Block_Instance_Acc) + is + Decl : constant Iir := Instance.Label; + begin + Disp_Instance_Name (Instance); + New_Line; + case Get_Kind (Decl) is + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Declaration => + Disp_Declaration_Objects + (Instance, Get_Interface_Declaration_Chain (Decl)); + Disp_Declaration_Objects + (Instance, + Get_Declaration_Chain (Get_Subprogram_Body (Decl))); + when Iir_Kind_Architecture_Body => + declare + Entity : constant Iir_Entity_Declaration := Get_Entity (Decl); + begin + Disp_Declaration_Objects + (Instance, Get_Generic_Chain (Entity)); + Disp_Declaration_Objects + (Instance, Get_Port_Chain (Entity)); + Disp_Declaration_Objects + (Instance, Get_Declaration_Chain (Entity)); + Disp_Declaration_Objects + (Instance, Get_Declaration_Chain (Decl)); + -- FIXME: processes. + end; + when Iir_Kind_Component_Instantiation_Statement => + null; + when others => + Error_Kind ("disp_objects", Decl); + end case; + end Disp_Objects; + pragma Unreferenced (Disp_Objects); + + procedure Disp_Process_Stats + is + Proc : Iir; + Stmt : Iir; + Nbr_User_Sensitized_Processes : Natural := 0; + Nbr_User_If_Sensitized_Processes : Natural := 0; + Nbr_Conc_Sensitized_Processes : Natural := 0; + Nbr_User_Non_Sensitized_Processes : Natural := 0; + Nbr_Conc_Non_Sensitized_Processes : Natural := 0; + begin + for I in Processes_Table.First .. Processes_Table.Last loop + Proc := Processes_Table.Table (I).Label; + case Get_Kind (Proc) is + when Iir_Kind_Sensitized_Process_Statement => + if Get_Process_Origin (Proc) = Null_Iir then + Stmt := Get_Sequential_Statement_Chain (Proc); + if Stmt /= Null_Iir + and then Get_Kind (Stmt) = Iir_Kind_If_Statement + and then Get_Chain (Stmt) = Null_Iir + then + Nbr_User_If_Sensitized_Processes := + Nbr_User_If_Sensitized_Processes + 1; + else + Nbr_User_Sensitized_Processes := + Nbr_User_Sensitized_Processes + 1; + end if; + else + Nbr_Conc_Sensitized_Processes := + Nbr_Conc_Sensitized_Processes + 1; + end if; + when Iir_Kind_Process_Statement => + if Get_Process_Origin (Proc) = Null_Iir then + Nbr_User_Non_Sensitized_Processes := + Nbr_User_Non_Sensitized_Processes + 1; + else + Nbr_Conc_Non_Sensitized_Processes := + Nbr_Conc_Non_Sensitized_Processes + 1; + end if; + when others => + raise Internal_Error; + end case; + end loop; + + Put (Natural'Image (Nbr_User_If_Sensitized_Processes)); + Put_Line (" user sensitized processes with only a if stmt"); + Put (Natural'Image (Nbr_User_Sensitized_Processes)); + Put_Line (" user sensitized processes (others)"); + Put (Natural'Image (Nbr_User_Non_Sensitized_Processes)); + Put_Line (" user non sensitized processes"); + Put (Natural'Image (Nbr_Conc_Sensitized_Processes)); + Put_Line (" sensitized concurrent statements"); + Put (Natural'Image (Nbr_Conc_Non_Sensitized_Processes)); + Put_Line (" non sensitized concurrent statements"); + Put (Process_Index_Type'Image (Processes_Table.Last)); + Put_Line (" processes (total)"); + end Disp_Process_Stats; + + procedure Disp_Signals_Stats + is + type Counters_Type is array (Signal_Type_Kind) of Natural; + Counters : Counters_Type := (others => 0); + Nbr_Signal_Elements : Natural := 0; + begin + for I in Signals_Table.First .. Signals_Table.Last loop + declare + Ent : Signal_Entry renames Signals_Table.Table (I); + begin + if Ent.Kind = User_Signal then + Nbr_Signal_Elements := Nbr_Signal_Elements + + Get_Nbr_Of_Scalars (Signals_Table.Table (I).Sig); + end if; + Counters (Ent.Kind) := Counters (Ent.Kind) + 1; + end; + end loop; + Put (Integer'Image (Counters (User_Signal))); + Put_Line (" declared user signals or ports"); + Put (Integer'Image (Nbr_Signal_Elements)); + Put_Line (" user signals sub-elements"); + Put (Integer'Image (Counters (Implicit_Quiet))); + Put_Line (" 'quiet implicit signals"); + Put (Integer'Image (Counters (Implicit_Stable))); + Put_Line (" 'stable implicit signals"); + Put (Integer'Image (Counters (Implicit_Delayed))); + Put_Line (" 'delayed implicit signals"); + Put (Integer'Image (Counters (Implicit_Transaction))); + Put_Line (" 'transaction implicit signals"); + Put (Integer'Image (Counters (Guard_Signal))); + Put_Line (" guard signals"); + end Disp_Signals_Stats; + + procedure Disp_Design_Stats is + begin + Disp_Process_Stats; + + New_Line; + + Disp_Signals_Stats; + + New_Line; + + Put (Integer'Image (Connect_Table.Last)); + Put_Line (" connections"); + end Disp_Design_Stats; + + procedure Disp_Design_Non_Sensitized + is + Instance : Block_Instance_Acc; + Proc : Iir; + begin + for I in Processes_Table.First .. Processes_Table.Last loop + Instance := Processes_Table.Table (I); + Proc := Processes_Table.Table (I).Label; + if Get_Kind (Proc) = Iir_Kind_Process_Statement then + Disp_Instance_Name (Instance); + New_Line; + Put_Line (" at " & Disp_Location (Proc)); + end if; + end loop; + end Disp_Design_Non_Sensitized; + + procedure Disp_Design_Connections is + begin + for I in Connect_Table.First .. Connect_Table.Last loop + declare + Conn : Connect_Entry renames Connect_Table.Table (I); + begin + Disp_Iir_Location (Conn.Assoc); + New_Line; + end; + end loop; + end Disp_Design_Connections; + + function Walk_Files (Cb : Walk_Cb) return Walk_Status + is + Lib : Iir_Library_Declaration := Libraries.Get_Libraries_Chain; + File : Iir_Design_File; + begin + while Lib /= Null_Iir loop + File := Get_Design_File_Chain (Lib); + while File /= Null_Iir loop + case Cb.all (File) is + when Walk_Continue => + null; + when Walk_Up => + exit; + when Walk_Abort => + return Walk_Abort; + end case; + File := Get_Chain (File); + end loop; + Lib := Get_Chain (Lib); + end loop; + return Walk_Continue; + end Walk_Files; + + Walk_Units_Cb : Walk_Cb; + + function Cb_Walk_Units (Design_File : Iir) return Walk_Status + is + Unit : Iir_Design_Unit; + begin + Unit := Get_First_Design_Unit (Design_File); + while Unit /= Null_Iir loop + case Walk_Units_Cb.all (Get_Library_Unit (Unit)) is + when Walk_Continue => + null; + when Walk_Abort => + return Walk_Abort; + when Walk_Up => + exit; + end case; + Unit := Get_Chain (Unit); + end loop; + return Walk_Continue; + end Cb_Walk_Units; + + function Walk_Units (Cb : Walk_Cb) return Walk_Status is + begin + Walk_Units_Cb := Cb; + return Walk_Files (Cb_Walk_Units'Access); + end Walk_Units; + + Walk_Declarations_Cb : Walk_Cb; + + function Cb_Walk_Declarations (Unit : Iir) return Walk_Status + is + function Walk_Decl_Chain (Chain : Iir) return Walk_Status + is + Decl : Iir; + begin + Decl := Chain; + while Decl /= Null_Iir loop + case Walk_Declarations_Cb.all (Decl) is + when Walk_Abort => + return Walk_Abort; + when Walk_Up => + return Walk_Continue; + when Walk_Continue => + null; + end case; + Decl := Get_Chain (Decl); + end loop; + return Walk_Continue; + end Walk_Decl_Chain; + + function Walk_Conc_Chain (Chain : Iir) return Walk_Status + is + Stmt : Iir := Chain; + begin + while Stmt /= Null_Iir loop + case Get_Kind (Stmt) is + when Iir_Kind_Process_Statement => + if Walk_Decl_Chain (Get_Declaration_Chain (Stmt)) + = Walk_Abort + then + return Walk_Abort; + end if; + when others => + Error_Kind ("walk_conc_chain", Stmt); + end case; + Stmt := Get_Chain (Stmt); + end loop; + return Walk_Continue; + end Walk_Conc_Chain; + begin + case Get_Kind (Unit) is + when Iir_Kind_Entity_Declaration => + if Walk_Decl_Chain (Get_Generic_Chain (Unit)) = Walk_Abort + or else Walk_Decl_Chain (Get_Port_Chain (Unit)) = Walk_Abort + or else (Walk_Decl_Chain + (Get_Declaration_Chain (Unit)) = Walk_Abort) + or else (Walk_Conc_Chain + (Get_Concurrent_Statement_Chain (Unit)) = Walk_Abort) + then + return Walk_Abort; + end if; + when Iir_Kind_Architecture_Body => + if (Walk_Decl_Chain + (Get_Declaration_Chain (Unit)) = Walk_Abort) + or else (Walk_Conc_Chain + (Get_Concurrent_Statement_Chain (Unit)) = Walk_Abort) + then + return Walk_Abort; + end if; + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Body => + if Walk_Decl_Chain (Get_Declaration_Chain (Unit)) = Walk_Abort + then + return Walk_Abort; + end if; + when Iir_Kind_Configuration_Declaration => + if Walk_Decl_Chain (Get_Declaration_Chain (Unit)) = Walk_Abort + then + return Walk_Abort; + end if; + -- FIXME: block configuration ? + when others => + Error_Kind ("Cb_Walk_Declarations", Unit); + end case; + return Walk_Continue; + end Cb_Walk_Declarations; + + function Walk_Declarations (Cb : Walk_Cb) return Walk_Status is + begin + Walk_Declarations_Cb := Cb; + return Walk_Units (Cb_Walk_Declarations'Access); + end Walk_Declarations; + + function Is_Blank (C : Character) return Boolean is + begin + return C = ' ' or else C = ASCII.HT; + end Is_Blank; + + function Skip_Blanks (S : String) return Positive + is + P : Positive := S'First; + begin + while P <= S'Last and then Is_Blank (S (P)) loop + P := P + 1; + end loop; + return P; + end Skip_Blanks; + + -- Return the position of the last character of the word (the last + -- non-blank character). + function Get_Word (S : String) return Positive + is + P : Positive := S'First; + begin + while P <= S'Last and then not Is_Blank (S (P)) loop + P := P + 1; + end loop; + return P - 1; + end Get_Word; + + procedure Disp_A_Frame (Instance: Block_Instance_Acc) is + begin + Put (Disp_Node (Instance.Label)); + if Instance.Stmt /= Null_Iir then + Put (" at "); + Put (Get_Location_Str (Get_Location (Instance.Stmt))); + end if; + New_Line; + end Disp_A_Frame; + + type Menu_Kind is (Menu_Command, Menu_Submenu); + type Menu_Entry (Kind : Menu_Kind); + type Menu_Entry_Acc is access all Menu_Entry; + + type Cst_String_Acc is access constant String; + + type Menu_Procedure is access procedure (Line : String); + + type Menu_Entry (Kind : Menu_Kind) is record + Name : Cst_String_Acc; + Next : Menu_Entry_Acc; + + case Kind is + when Menu_Command => + Proc : Menu_Procedure; + when Menu_Submenu => + First, Last : Menu_Entry_Acc := null; + end case; + end record; + + -- Check there is a current process. + procedure Check_Current_Process is + begin + if Current_Process = null then + Put_Line ("no current process"); + raise Command_Error; + end if; + end Check_Current_Process; + + -- The status of the debugger. This status can be modified by a command + -- as a side effect to resume or quit the debugger. + type Command_Status_Type is (Status_Default, Status_Quit); + Command_Status : Command_Status_Type; + + procedure Help_Proc (Line : String); + + procedure Disp_Process_Loc (Proc : Process_State_Type) is + begin + Disp_Instance_Name (Proc.Top_Instance); + Put (" (" & Get_Location_Str (Get_Location (Proc.Proc)) & ")"); + New_Line; + end Disp_Process_Loc; + + -- Disp the list of processes (and its state) + procedure Ps_Proc (Line : String) is + pragma Unreferenced (Line); + Process : Iir; + begin + if Processes_State = null then + Put_Line ("no processes"); + return; + end if; + + for I in Processes_State'Range loop + Put (Process_Index_Type'Image (I) & ": "); + Process := Processes_State (I).Proc; + if Process /= Null_Iir then + Disp_Process_Loc (Processes_State (I)); + Disp_A_Frame (Processes_State (I).Instance); + else + Put_Line ("not yet elaborated"); + end if; + end loop; + end Ps_Proc; + + procedure Up_Proc (Line : String) + is + pragma Unreferenced (Line); + begin + Check_Current_Process; + if Dbg_Cur_Frame.Parent = null then + Put_Line ("top of frames reached"); + else + Set_Cur_Frame (Dbg_Cur_Frame.Parent); + end if; + end Up_Proc; + + procedure Down_Proc (Line : String) + is + pragma Unreferenced (Line); + Inst : Block_Instance_Acc; + begin + Check_Current_Process; + if Dbg_Cur_Frame = Dbg_Top_Frame then + Put_Line ("bottom of frames reached"); + else + Inst := Dbg_Top_Frame; + while Inst.Parent /= Dbg_Cur_Frame loop + Inst := Inst.Parent; + end loop; + Set_Cur_Frame (Inst); + end if; + end Down_Proc; + + procedure Set_Breakpoint (Stmt : Iir) is + begin + Put_Line + ("set breakpoint at: " & Get_Location_Str (Get_Location (Stmt))); + Breakpoints.Append (Breakpoint_Entry'(Stmt => Stmt)); + Flag_Need_Debug := True; + end Set_Breakpoint; + + procedure Next_Proc (Line : String) + is + pragma Unreferenced (Line); + begin + Exec_State := Exec_Next; + Exec_Instance := Dbg_Top_Frame; + Flag_Need_Debug := True; + Command_Status := Status_Quit; + end Next_Proc; + + procedure Step_Proc (Line : String) + is + pragma Unreferenced (Line); + begin + Exec_State := Exec_Single_Step; + Flag_Need_Debug := True; + Command_Status := Status_Quit; + end Step_Proc; + + Break_Id : Name_Id; + + function Cb_Set_Break (El : Iir) return Walk_Status is + begin + case Get_Kind (El) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + if Get_Identifier (El) = Break_Id then + Set_Breakpoint + (Get_Sequential_Statement_Chain (Get_Subprogram_Body (El))); + end if; + when others => + null; + end case; + return Walk_Continue; + end Cb_Set_Break; + + procedure Break_Proc (Line : String) + is + Status : Walk_Status; + P : Natural; + begin + P := Skip_Blanks (Line); + Break_Id := Name_Table.Get_Identifier (Line (P .. Line'Last)); + Status := Walk_Declarations (Cb_Set_Break'Access); + pragma Assert (Status = Walk_Continue); + end Break_Proc; + + procedure Where_Proc (Line : String) is + pragma Unreferenced (Line); + Frame : Block_Instance_Acc; + begin + Check_Current_Process; + Frame := Dbg_Top_Frame; + while Frame /= null loop + if Frame = Dbg_Cur_Frame then + Put ("* "); + else + Put (" "); + end if; + Disp_A_Frame (Frame); + Frame := Frame.Parent; + end loop; + end Where_Proc; + + procedure Info_Tree_Proc (Line : String) + is + pragma Unreferenced (Line); + begin + if Top_Instance = null then + Put_Line ("design not yet fully elaborated"); + else + Disp_Instances_Tree; + end if; + end Info_Tree_Proc; + + procedure Info_Params_Proc (Line : String) + is + pragma Unreferenced (Line); + Decl : Iir; + Params : Iir; + begin + Check_Current_Process; + Decl := Dbg_Cur_Frame.Label; + if Decl = Null_Iir + or else Get_Kind (Decl) not in Iir_Kinds_Subprogram_Declaration + then + Put_Line ("current frame is not a subprogram"); + return; + end if; + Params := Get_Interface_Declaration_Chain (Decl); + Disp_Declaration_Objects (Dbg_Cur_Frame, Params); + end Info_Params_Proc; + + procedure Info_Proc_Proc (Line : String) is + pragma Unreferenced (Line); + begin + Check_Current_Process; + Disp_Process_Loc (Current_Process.all); + end Info_Proc_Proc; + + function Cb_Disp_Subprograms (El : Iir) return Walk_Status is + begin + case Get_Kind (El) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + Put_Line (Name_Table.Image (Get_Identifier (El))); + when others => + null; + end case; + return Walk_Continue; + end Cb_Disp_Subprograms; + + procedure Info_Subprograms_Proc (Line : String) is + pragma Unreferenced (Line); + Status : Walk_Status; + begin + Status := Walk_Declarations (Cb_Disp_Subprograms'Access); + pragma Assert (Status = Walk_Continue); + end Info_Subprograms_Proc; + + function Cb_Disp_Units (El : Iir) return Walk_Status is + begin + case Get_Kind (El) is + when Iir_Kind_Package_Declaration => + Put ("package "); + Put_Line (Name_Table.Image (Get_Identifier (El))); + when Iir_Kind_Entity_Declaration => + Put ("entity "); + Put_Line (Name_Table.Image (Get_Identifier (El))); + when Iir_Kind_Architecture_Body => + Put ("architecture "); + Put (Name_Table.Image (Get_Identifier (El))); + Put (" of "); + Put_Line (Name_Table.Image (Get_Identifier (Get_Entity (El)))); + when Iir_Kind_Configuration_Declaration => + Put ("configuration "); + Put_Line (Name_Table.Image (Get_Identifier (El))); + when Iir_Kind_Package_Body => + null; + when others => + Error_Kind ("cb_disp_units", El); + end case; + return Walk_Continue; + end Cb_Disp_Units; + + procedure Info_Units_Proc (Line : String) is + pragma Unreferenced (Line); + Status : Walk_Status; + begin + Status := Walk_Units (Cb_Disp_Units'Access); + pragma Assert (Status = Walk_Continue); + end Info_Units_Proc; + + function Cb_Disp_File (El : Iir) return Walk_Status is + begin + Put_Line (Name_Table.Image (Get_Design_File_Filename (El))); + return Walk_Continue; + end Cb_Disp_File; + + procedure Info_Stats_Proc (Line : String) is + P : Natural := Line'First; + E : Natural; + begin + P := Skip_Blanks (Line (P .. Line'Last)); + if P > Line'Last then + -- No parameters. + Disp_Design_Stats; + return; + end if; + + E := Get_Word (Line (P .. Line'Last)); + if Line (P .. E) = "global" then + Disp_Design_Stats; + elsif Line (P .. E) = "non-sensitized" then + Disp_Design_Non_Sensitized; + null; + elsif Line (P .. E) = "connections" then + Disp_Design_Connections; + -- TODO: nbr of conversions + else + Put_Line ("options are: global, non-sensitized, connections"); + -- TODO: signals: nbr of scalars, nbr of non-user... + end if; + end Info_Stats_Proc; + + procedure Info_Files_Proc (Line : String) is + pragma Unreferenced (Line); + Status : Walk_Status; + begin + Status := Walk_Files (Cb_Disp_File'Access); + pragma Assert (Status = Walk_Continue); + end Info_Files_Proc; + + procedure Info_Libraries_Proc (Line : String) is + pragma Unreferenced (Line); + Lib : Iir_Library_Declaration := Libraries.Get_Libraries_Chain; + begin + while Lib /= Null_Iir loop + Put_Line (Name_Table.Image (Get_Identifier (Lib))); + Lib := Get_Chain (Lib); + end loop; + end Info_Libraries_Proc; + + procedure Disp_Declared_Signals_Chain + (Chain : Iir; Instance : Block_Instance_Acc) + is + pragma Unreferenced (Instance); + Decl : Iir; + begin + Decl := Chain; + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Signal_Interface_Declaration + | Iir_Kind_Signal_Declaration => + Put_Line (" " & Name_Table.Image (Get_Identifier (Decl))); + when others => + null; + end case; + Decl := Get_Chain (Decl); + end loop; + end Disp_Declared_Signals_Chain; + + procedure Disp_Declared_Signals (Decl : Iir; Instance : Block_Instance_Acc) + is + begin + case Get_Kind (Decl) is + when Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement => + Disp_Declared_Signals (Get_Parent (Decl), Instance); + when Iir_Kind_Architecture_Body => + Disp_Declared_Signals (Get_Entity (Decl), Instance); + when Iir_Kind_Entity_Declaration => + null; + when others => + Error_Kind ("disp_declared_signals", Decl); + end case; + + case Get_Kind (Decl) is + when Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement => + -- No signal declaration in a process (FIXME: implicit signals) + null; + when Iir_Kind_Architecture_Body => + Put_Line ("Signals of architecture " + & Name_Table.Image (Get_Identifier (Decl)) & ':'); + Disp_Declared_Signals_Chain + (Get_Declaration_Chain (Decl), Instance); + when Iir_Kind_Entity_Declaration => + Put_Line ("Ports of entity " + & Name_Table.Image (Get_Identifier (Decl)) & ':'); + Disp_Declared_Signals_Chain + (Get_Port_Chain (Decl), Instance); + when others => + Error_Kind ("disp_declared_signals (2)", Decl); + end case; + end Disp_Declared_Signals; + + procedure Info_Signals_Proc (Line : String) is + pragma Unreferenced (Line); + begin + Check_Current_Process; + Disp_Declared_Signals + (Current_Process.Proc, Current_Process.Top_Instance); + end Info_Signals_Proc; + + type Handle_Scope_Type is access procedure (N : Iir); + + procedure Foreach_Scopes (N : Iir; Handler : Handle_Scope_Type) is + begin + case Get_Kind (N) is + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Foreach_Scopes (Get_Parent (N), Handler); + Handler.all (N); + when Iir_Kind_Architecture_Body => + Foreach_Scopes (Get_Entity (N), Handler); + Handler.all (N); + + when Iir_Kind_Entity_Declaration => + -- Top of scopes. + null; + + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + Foreach_Scopes (Get_Parent (N), Handler); + Handler.all (N); + when Iir_Kind_Package_Body => + Handler.all (N); + + when Iir_Kind_Variable_Assignment_Statement + | Iir_Kind_Signal_Assignment_Statement + | Iir_Kind_Null_Statement + | Iir_Kind_Assertion_Statement + | Iir_Kind_Report_Statement + | Iir_Kind_Wait_Statement + | Iir_Kind_Return_Statement + | Iir_Kind_Next_Statement + | Iir_Kind_Exit_Statement + | Iir_Kind_Procedure_Call_Statement + | Iir_Kind_If_Statement + | Iir_Kind_While_Loop_Statement + | Iir_Kind_Case_Statement => + Foreach_Scopes (Get_Parent (N), Handler); + + when Iir_Kind_For_Loop_Statement + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement => + Foreach_Scopes (Get_Parent (N), Handler); + Handler.all (N); + + when others => + Error_Kind ("foreach_scopes", N); + end case; + end Foreach_Scopes; + + procedure Add_Decls_For (N : Iir) + is + use Sem_Scopes; + begin + case Get_Kind (N) is + when Iir_Kind_Entity_Declaration => + declare + Unit : constant Iir := Get_Design_Unit (N); + begin + Add_Context_Clauses (Unit); + -- Add_Name (Unit, Get_Identifier (N), False); + Add_Entity_Declarations (N); + end; + when Iir_Kind_Architecture_Body => + Open_Declarative_Region; + Add_Context_Clauses (Get_Design_Unit (N)); + Add_Declarations (Get_Declaration_Chain (N), False); + Add_Declarations_Of_Concurrent_Statement (N); + when Iir_Kind_Package_Body => + declare + Package_Decl : constant Iir := Get_Package (N); + Package_Unit : constant Iir := Get_Design_Unit (Package_Decl); + begin + Add_Name (Package_Unit); + Add_Context_Clauses (Package_Unit); + Open_Declarative_Region; + Add_Declarations (Get_Declaration_Chain (Package_Decl), False); + Add_Declarations (Get_Declaration_Chain (N), False); + end; + when Iir_Kind_Procedure_Body + | Iir_Kind_Function_Body => + declare + Spec : constant Iir := Get_Subprogram_Specification (N); + begin + Open_Declarative_Region; + Add_Declarations + (Get_Interface_Declaration_Chain (Spec), False); + Add_Declarations + (Get_Declaration_Chain (N), False); + end; + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Open_Declarative_Region; + Add_Declarations (Get_Declaration_Chain (N), False); + when Iir_Kind_For_Loop_Statement => + Open_Declarative_Region; + Add_Name (Get_Parameter_Specification (N)); + when Iir_Kind_Block_Statement => + Open_Declarative_Region; + Add_Declarations (Get_Declaration_Chain (N), False); + Add_Declarations_Of_Concurrent_Statement (N); + when Iir_Kind_Generate_Statement => + Open_Declarative_Region; + Add_Declarations (Get_Declaration_Chain (N), False); + Add_Declarations_Of_Concurrent_Statement (N); + when others => + Error_Kind ("enter_scope(2)", N); + end case; + end Add_Decls_For; + + procedure Enter_Scope (Node : Iir) + is + use Sem_Scopes; + begin + Push_Interpretations; + Open_Declarative_Region; + + -- Add STD + Add_Name (Libraries.Std_Library, Std_Names.Name_Std, False); + Use_All_Names (Std_Package.Standard_Package); + + Foreach_Scopes (Node, Add_Decls_For'Access); + end Enter_Scope; + + procedure Del_Decls_For (N : Iir) + is + use Sem_Scopes; + begin + case Get_Kind (N) is + when Iir_Kind_Entity_Declaration => + null; + when Iir_Kind_Architecture_Body => + Close_Declarative_Region; + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Package_Body + | Iir_Kind_Procedure_Body + | Iir_Kind_Function_Body + | Iir_Kind_For_Loop_Statement + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement => + Close_Declarative_Region; + when others => + Error_Kind ("Decl_Decls_For", N); + end case; + end Del_Decls_For; + + procedure Leave_Scope (Node : Iir) + is + use Sem_Scopes; + begin + Foreach_Scopes (Node, Del_Decls_For'Access); + + Close_Declarative_Region; + Pop_Interpretations; + end Leave_Scope; + + Buffer_Index : Natural := 1; + + procedure Print_Proc (Line : String) + is + use Tokens; + Index_Str : String := Natural'Image (Buffer_Index); + File : Source_File_Entry; + Expr : Iir; + Res : Iir_Value_Literal_Acc; + P : Natural; + Opt_Value : Boolean := False; + Marker : Mark_Type; + begin + -- Decode options: /v + P := Line'First; + loop + P := Skip_Blanks (Line (P .. Line'Last)); + if P + 2 < Line'Last and then Line (P .. P + 1) = "/v" then + Opt_Value := True; + P := P + 2; + else + exit; + end if; + end loop; + + Buffer_Index := Buffer_Index + 1; + Index_Str (Index_Str'First) := '*'; + File := Files_Map.Create_Source_File_From_String + (Name_Table.Get_Identifier ("*debug" & Index_Str & '*'), + Line (P .. Line'Last)); + Scanner.Set_File (File); + Scanner.Scan; + Expr := Parse.Parse_Expression; + if Scanner.Current_Token /= Tok_Eof then + Put_Line ("garbage at end of expression ignored"); + end if; + Scanner.Close_File; + if Nbr_Errors /= 0 then + Put_Line ("error while parsing expression, evaluation aborted"); + Nbr_Errors := 0; + return; + end if; + + Enter_Scope (Dbg_Cur_Frame.Stmt); + Expr := Sem_Expr.Sem_Expression_Universal (Expr); + Leave_Scope (Dbg_Cur_Frame.Stmt); + + if Expr = Null_Iir + or else Nbr_Errors /= 0 + then + Put_Line ("error while analyzing expression, evaluation aborted"); + Nbr_Errors := 0; + return; + end if; + + Disp_Vhdl.Disp_Expression (Expr); + New_Line; + + Annotate_Expand_Table; + + Mark (Marker, Expr_Pool); + + Res := Execute_Expression (Dbg_Cur_Frame, Expr); + if Opt_Value then + Disp_Value (Res); + else + Disp_Iir_Value (Res, Get_Type (Expr)); + end if; + New_Line; + + -- Free value + Release (Marker, Expr_Pool); + end Print_Proc; + + procedure Quit_Proc (Line : String) is + pragma Unreferenced (Line); + begin + Command_Status := Status_Quit; + raise Debugger_Quit; + end Quit_Proc; + + procedure Cont_Proc (Line : String) is + pragma Unreferenced (Line); + begin + Command_Status := Status_Quit; + + -- Set Flag_Need_Debug only if there is at least one enabled breakpoint. + Flag_Need_Debug := False; + for I in Breakpoints.First .. Breakpoints.Last loop + Flag_Need_Debug := True; + exit; + end loop; + end Cont_Proc; + + Menu_Info_Stats : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("stats"), + Next => null, + Proc => Info_Stats_Proc'Access); + + Menu_Info_Tree : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("tree"), + Next => Menu_Info_Stats'Access, + Proc => Info_Tree_Proc'Access); + + Menu_Info_Params : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("param*eters"), + Next => Menu_Info_Tree'Access, + Proc => Info_Params_Proc'Access); + + Menu_Info_Subprograms : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("subp*rograms"), + Next => Menu_Info_Params'Access, + Proc => Info_Subprograms_Proc'Access); + + Menu_Info_Units : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("units"), + Next => Menu_Info_Subprograms'Access, + Proc => Info_Units_Proc'Access); + + Menu_Info_Files : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("files"), + Next => Menu_Info_Units'Access, + Proc => Info_Files_Proc'Access); + + Menu_Info_Libraries : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("lib*raries"), + Next => Menu_Info_Files'Access, + Proc => Info_Libraries_Proc'Access); + + Menu_Info_Signals : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("sig*nals"), + Next => Menu_Info_Libraries'Access, + Proc => Info_Signals_Proc'Access); + + Menu_Info_Proc : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("proc*esses"), + Next => Menu_Info_Signals'Access, + Proc => Info_Proc_Proc'Access); + + Menu_Down : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("down"), + Next => null, + Proc => Down_Proc'Access); + + Menu_Up : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("up"), + Next => Menu_Down'Access, + Proc => Up_Proc'Access); + + Menu_Next : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("n*ext"), + Next => Menu_Up'Access, + Proc => Next_Proc'Access); + + Menu_Step : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("s*tep"), + Next => Menu_Next'Access, + Proc => Step_Proc'Access); + + Menu_Break : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("b*reak"), + Next => Menu_Step'Access, + Proc => Break_Proc'Access); + + Menu_Where : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("where"), + Next => Menu_Break'Access, + Proc => Where_Proc'Access); + + Menu_Ps : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("ps"), + Next => Menu_Where'Access, + Proc => Ps_Proc'Access); + + Menu_Info : aliased Menu_Entry := + (Kind => Menu_Submenu, + Name => new String'("i*nfo"), + Next => Menu_Ps'Access, + First | Last => Menu_Info_Proc'Access); + + Menu_Print : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("pr*int"), + Next => Menu_Info'Access, + Proc => Print_Proc'Access); + + Menu_Cont : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("c*ont"), + Next => Menu_Print'Access, + Proc => Cont_Proc'Access); + + Menu_Quit : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("q*uit"), + Next => Menu_Cont'Access, + Proc => Quit_Proc'Access); + + Menu_Help1 : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("help"), + Next => Menu_Quit'Access, + Proc => Help_Proc'Access); + + Menu_Help2 : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("?"), + Next => Menu_Help1'Access, + Proc => Help_Proc'Access); + + Menu_Top : aliased Menu_Entry := + (Kind => Menu_Submenu, + Name => null, + Next => null, + First | Last => Menu_Help2'Access); + + function Find_Menu (Menu : Menu_Entry_Acc; Cmd : String) + return Menu_Entry_Acc + is + function Is_Cmd (Cmd_Name : String; Str : String) return Boolean + is + -- Number of characters that were compared. + P : Natural; + begin + P := 0; + -- Prefix (before the '*'). + loop + if P = Cmd_Name'Length then + -- Full match. + return P = Str'Length; + end if; + exit when Cmd_Name (Cmd_Name'First + P) = '*'; + if P = Str'Length then + -- Command is too short + return False; + end if; + if Cmd_Name (Cmd_Name'First + P) /= Str (Str'First + P) then + return False; + end if; + P := P + 1; + end loop; + -- Suffix (after the '*') + loop + if P = Str'Length then + return True; + end if; + if P + 1 = Cmd_Name'Length then + -- String is too long + return False; + end if; + if Cmd_Name (Cmd_Name'First + P + 1) /= Str (Str'First + P) then + return False; + end if; + P := P + 1; + end loop; + end Is_Cmd; + Ent : Menu_Entry_Acc; + begin + Ent := Menu.First; + while Ent /= null loop + if Is_Cmd (Ent.Name.all, Cmd) then + return Ent; + end if; + Ent := Ent.Next; + end loop; + return null; + end Find_Menu; + + procedure Parse_Command (Line : String; + P : in out Natural; + Menu : out Menu_Entry_Acc) + is + E : Natural; + begin + P := Skip_Blanks (Line (P .. Line'Last)); + if P > Line'Last then + return; + end if; + E := Get_Word (Line (P .. Line'Last)); + Menu := Find_Menu (Menu, Line (P .. E)); + if Menu = null then + Put_Line ("command '" & Line (P .. E) & "' not found"); + end if; + P := E + 1; + end Parse_Command; + + procedure Help_Proc (Line : String) is + P : Natural; + Root : Menu_Entry_Acc := Menu_Top'access; + begin + Put_Line ("This is the help command"); + P := Line'First; + while P < Line'Last loop + Parse_Command (Line, P, Root); + if Root = null then + return; + elsif Root.Kind /= Menu_Submenu then + Put_Line ("Menu entry " & Root.Name.all & " is not a submenu"); + return; + end if; + end loop; + + Root := Root.First; + while Root /= null loop + Put (Root.Name.all); + if Root.Kind = Menu_Submenu then + Put (" (menu)"); + end if; + New_Line; + Root := Root.Next; + end loop; + end Help_Proc; + + procedure Disp_Source_Line (Loc : Location_Type) + is + use Files_Map; + + File : Source_File_Entry; + Line_Pos : Source_Ptr; + Line : Natural; + Offset : Natural; + Buf : File_Buffer_Acc; + Next_Line_Pos : Source_Ptr; + begin + Location_To_Coord (Loc, File, Line_Pos, Line, Offset); + Buf := Get_File_Source (File); + Next_Line_Pos := Line_To_Position (File, Line + 1); + Put (String (Buf (Line_Pos .. Next_Line_Pos - 1))); + end Disp_Source_Line; + + function Breakpoint_Hit return Natural + is + Stmt : constant Iir := Current_Process.Instance.Stmt; + begin + for I in Breakpoints.First .. Breakpoints.Last loop + if Stmt = Breakpoints.Table (I).Stmt then + return I; + end if; + end loop; + return 0; + end Breakpoint_Hit; + + Prompt_Debug : constant String := "debug> " & ASCII.NUL; + Prompt_Crash : constant String := "crash> " & ASCII.NUL; + Prompt_Init : constant String := "init> " & ASCII.NUL; + Prompt_Elab : constant String := "elab> " & ASCII.NUL; + + procedure Debug (Reason: Debug_Reason) is + use Grt.Readline; + Raw_Line : Char_Ptr; + Prompt : System.Address; + begin + -- Unless interractive, do not use the debugger. + if Reason /= Reason_Internal_Debug then + if not Flag_Interractive then + return; + end if; + end if; + + Prompt := Prompt_Debug'Address; + + case Reason is + when Reason_Start => + Set_Top_Frame (null); + Prompt := Prompt_Init'Address; + when Reason_Elab => + Set_Top_Frame (null); + Prompt := Prompt_Elab'Address; + when Reason_Internal_Debug => + if Current_Process = null then + Set_Top_Frame (null); + else + Set_Top_Frame (Current_Process.Instance); + end if; + when Reason_Break => + case Exec_State is + when Exec_Run => + if Breakpoint_Hit /= 0 then + Put_Line ("breakpoint hit"); + else + return; + end if; + when Exec_Single_Step => + -- Default state. + Exec_State := Exec_Run; + when Exec_Next => + if Current_Process.Instance /= Exec_Instance then + return; + end if; + -- Default state. + Exec_State := Exec_Run; + end case; + Set_Top_Frame (Current_Process.Instance); + declare + Stmt : constant Iir := Dbg_Cur_Frame.Stmt; + begin + Put ("stopped at: "); + Disp_Iir_Location (Stmt); + New_Line; + Disp_Source_Line (Get_Location (Stmt)); + end; + when Reason_Assert => + Set_Top_Frame (Current_Process.Instance); + Prompt := Prompt_Crash'Address; + Put_Line ("assertion failure, enterring in debugger"); + when Reason_Error => + Set_Top_Frame (Current_Process.Instance); + Prompt := Prompt_Crash'Address; + Put_Line ("error occurred, enterring in debugger"); + end case; + + Command_Status := Status_Default; + + loop + loop + Raw_Line := Readline (Prompt); + -- Skip empty lines + exit when Raw_Line /= null and then Raw_Line (1) /= ASCII.NUL; + end loop; + declare + Line_Last : constant Natural := Strlen (Raw_Line); + Line : String renames Raw_Line (1 .. Line_Last); + P, E : Positive; + Cmd : Menu_Entry_Acc := Menu_Top'Access; + begin + -- Find command + P := 1; + loop + E := P; + Parse_Command (Line, E, Cmd); + exit when Cmd = null; + case Cmd.Kind is + when Menu_Submenu => + if E > Line_Last then + Put_Line ("missing command for submenu " + & Line (P .. E - 1)); + Cmd := null; + exit; + end if; + P := E; + when Menu_Command => + exit; + end case; + end loop; + + if Cmd /= null then + Cmd.Proc.all (Line (E .. Line_Last)); + + case Command_Status is + when Status_Default => + null; + when Status_Quit => + exit; + end case; + end if; + exception + when Command_Error => + null; + end; + end loop; + -- Put ("resuming"); + end Debug; + + procedure Debug_Error is + begin + Debug (Reason_Error); + end Debug_Error; +end Debugger; diff --git a/src/simulate/debugger.ads b/src/simulate/debugger.ads new file mode 100644 index 000000000..5e8c7ac67 --- /dev/null +++ b/src/simulate/debugger.ads @@ -0,0 +1,90 @@ +-- Debugger for interpreter +-- Copyright (C) 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 GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Elaboration; use Elaboration; +with Iirs; use Iirs; + +package Debugger is + Flag_Need_Debug : Boolean := False; + + -- Disp a message for a constraint error. + -- And raise the exception execution_constraint_error. + procedure Error_Msg_Constraint (Expr: Iir); + pragma No_Return (Error_Msg_Constraint); + + -- Disp a message during execution. + procedure Error_Msg_Exec (Msg: String; Loc: Iir); + pragma No_Return (Error_Msg_Exec); + + procedure Warning_Msg_Exec (Msg: String; Loc: Iir); + + -- Disp a block instance, in a human readable way. + -- Used to debug. + procedure Disp_Block_Instance (Instance: Block_Instance_Acc); + + -- Disp the instance tree. + procedure Disp_Instances_Tree; + + -- Disp the name of an instance, without newline. The name of + -- architectures is displayed unless Short is True. + procedure Disp_Instance_Name (Instance: Block_Instance_Acc; + Short : Boolean := False); + + -- Disp the resulting processes of elaboration. + -- procedure Disp_Processes; + + -- Disp the label of PROCESS, or <unlabeled> if PROCESS has no label. + procedure Disp_Label (Process : Iir); + + -- Disp all signals name and values. + procedure Disp_Signals_Value; + + procedure Disp_Objects_Value; + + -- Disp stats about the design (number of process, number of signals...) + procedure Disp_Design_Stats; + + -- The reason why the debugger is invoked. + type Debug_Reason is + (-- Called from an external debugger while debugging ghdl. + Reason_Internal_Debug, + + -- Interractive session, elaboration not done + Reason_Start, + + -- At end of elaboration, for an interractive session + Reason_Elab, + + -- Before execution of a statement. + Reason_Break, + + -- Assertion failure + Reason_Assert, + + -- Non recoverable error occurred (such as index error, overflow...) + Reason_Error + ); + + Debugger_Quit : exception; + + -- Interractive debugger. + procedure Debug (Reason: Debug_Reason); + + -- Call the debugger in case of error. + procedure Debug_Error; +end Debugger; diff --git a/src/simulate/elaboration.adb b/src/simulate/elaboration.adb new file mode 100644 index 000000000..dd405ec18 --- /dev/null +++ b/src/simulate/elaboration.adb @@ -0,0 +1,2582 @@ +-- Elaboration +-- Copyright (C) 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 GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Ada.Text_IO; +with Types; use Types; +with Errorout; use Errorout; +with Execution; use Execution; +with Simulation; use Simulation; +with Iirs_Utils; use Iirs_Utils; +with Libraries; +with Name_Table; +with File_Operation; +with Debugger; use Debugger; +with Iir_Chains; use Iir_Chains; +with Sem_Names; +with Grt.Types; use Grt.Types; +with Simulation.AMS; use Simulation.AMS; +with Areapools; use Areapools; +with Grt.Errors; + +package body Elaboration is + + procedure Elaborate_Dependence (Design_Unit: Iir_Design_Unit); + + procedure Elaborate_Statement_Part + (Instance : Block_Instance_Acc; Stmt_Chain: Iir); + procedure Elaborate_Type_Definition + (Instance : Block_Instance_Acc; Def : Iir); + procedure Elaborate_Nature_Definition + (Instance : Block_Instance_Acc; Def : Iir); + + function Elaborate_Default_Value + (Instance : Block_Instance_Acc; Decl : Iir) + return Iir_Value_Literal_Acc; + + -- CONF is the block_configuration for components of ARCH. + function Elaborate_Architecture (Arch : Iir_Architecture_Body; + Conf : Iir_Block_Configuration; + Parent_Instance : Block_Instance_Acc; + Stmt : Iir; + Generic_Map : Iir; + Port_Map : Iir) + return Block_Instance_Acc; + + -- Create a new signal, using DEFAULT as initial value. + -- Set its number. + procedure Elaborate_Signal (Block: Block_Instance_Acc; + Signal: Iir; + Default : Iir_Value_Literal_Acc) + is + function Create_Signal (Lit: Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + begin + case Lit.Kind is + when Iir_Value_Array => + Res := Create_Array_Value (Lit.Val_Array.Len, + Lit.Bounds.Nbr_Dims); + Res.Bounds.D := Lit.Bounds.D; + Res := Unshare_Bounds (Res, Global_Pool'Access); + + for I in Lit.Val_Array.V'Range loop + Res.Val_Array.V (I) := Create_Signal (Lit.Val_Array.V (I)); + end loop; + when Iir_Value_Record => + Res := Create_Record_Value + (Lit.Val_Record.Len, Instance_Pool); + for I in Lit.Val_Record.V'Range loop + Res.Val_Record.V (I) := Create_Signal (Lit.Val_Record.V (I)); + end loop; + + when Iir_Value_I64 + | Iir_Value_F64 + | Iir_Value_B1 + | Iir_Value_E32 => + Res := Create_Signal_Value (null); + + when Iir_Value_Signal + | Iir_Value_Range + | Iir_Value_File + | Iir_Value_Access + | Iir_Value_Protected + | Iir_Value_Quantity + | Iir_Value_Terminal => + raise Internal_Error; + end case; + return Res; + end Create_Signal; + + Sig : Iir_Value_Literal_Acc; + Def : Iir_Value_Literal_Acc; + Slot : constant Object_Slot_Type := Get_Info (Signal).Slot; + begin + Sig := Create_Signal (Default); + Def := Unshare (Default, Global_Pool'Access); + Block.Objects (Slot) := Sig; + Block.Objects (Slot + 1) := Def; + + Signals_Table.Append ((Kind => User_Signal, + Decl => Signal, + Sig => Sig, + Instance => Block, + Init => Def)); + end Elaborate_Signal; + + function Execute_Time_Attribute (Instance : Block_Instance_Acc; Attr : Iir) + return Ghdl_I64 + is + Param : constant Iir := Get_Parameter (Attr); + Res : Ghdl_I64; + Val : Iir_Value_Literal_Acc; + begin + if Param = Null_Iir then + Res := 0; + else + Val := Execute_Expression (Instance, Param); + Res := Val.I64; + end if; + return Res; + end Execute_Time_Attribute; + + procedure Elaborate_Implicit_Signal + (Instance: Block_Instance_Acc; Signal: Iir; Kind : Signal_Type_Kind) + is + Info : constant Sim_Info_Acc := Get_Info (Signal); + Prefix : Iir_Value_Literal_Acc; + T : Ghdl_I64; + Sig : Iir_Value_Literal_Acc; + Init : Iir_Value_Literal_Acc; + begin + if Kind = Implicit_Transaction then + T := 0; + Init := Create_B1_Value (False); + else + T := Execute_Time_Attribute (Instance, Signal); + Init := Create_B1_Value (False); + end if; + Sig := Create_Signal_Value (null); + Instance.Objects (Info.Slot) := Sig; + Instance.Objects (Info.Slot + 1) := Unshare (Init, Global_Pool'Access); + + Prefix := Execute_Name (Instance, Get_Prefix (Signal), True); + Prefix := Unshare_Bounds (Prefix, Global_Pool'Access); + case Kind is + when Implicit_Stable => + Signals_Table.Append ((Kind => Implicit_Stable, + Decl => Signal, + Sig => Sig, + Instance => Instance, + Time => T, + Prefix => Prefix)); + when Implicit_Quiet => + Signals_Table.Append ((Kind => Implicit_Quiet, + Decl => Signal, + Sig => Sig, + Instance => Instance, + Time => T, + Prefix => Prefix)); + when Implicit_Transaction => + Signals_Table.Append ((Kind => Implicit_Transaction, + Decl => Signal, + Sig => Sig, + Instance => Instance, + Time => 0, + Prefix => Prefix)); + when others => + raise Internal_Error; + end case; + end Elaborate_Implicit_Signal; + + function Create_Delayed_Signal (Pfx : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + begin + case Pfx.Kind is + when Iir_Value_Array => + Res := Create_Array_Value (Pfx.Val_Array.Len, + Pfx.Bounds.Nbr_Dims, + Global_Pool'Access); + Res.Bounds.D := Pfx.Bounds.D; + + for I in Pfx.Val_Array.V'Range loop + Res.Val_Array.V (I) := Create_Delayed_Signal + (Pfx.Val_Array.V (I)); + end loop; + when Iir_Value_Record => + Res := Create_Record_Value (Pfx.Val_Record.Len, + Global_Pool'Access); + for I in Pfx.Val_Record.V'Range loop + Res.Val_Record.V (I) := Create_Delayed_Signal + (Pfx.Val_Record.V (I)); + end loop; + when Iir_Value_Signal => + Res := Create_Signal_Value (null); + when others => + raise Internal_Error; + end case; + return Res; + end Create_Delayed_Signal; + + procedure Elaborate_Delayed_Signal + (Instance: Block_Instance_Acc; Signal: Iir) + is + Info : constant Sim_Info_Acc := Get_Info (Signal); + Prefix : Iir_Value_Literal_Acc; + Sig : Iir_Value_Literal_Acc; + Init : Iir_Value_Literal_Acc; + T : Ghdl_I64; + begin + Prefix := Execute_Name (Instance, Get_Prefix (Signal), True); + Prefix := Unshare_Bounds (Prefix, Global_Pool'Access); + + T := Execute_Time_Attribute (Instance, Signal); + + Sig := Create_Delayed_Signal (Prefix); + Instance.Objects (Info.Slot) := Sig; + + Init := Execute_Signal_Init_Value (Instance, Get_Prefix (Signal)); + Init := Unshare_Bounds (Init, Global_Pool'Access); + Instance.Objects (Info.Slot + 1) := Init; + + Signals_Table.Append ((Kind => Implicit_Delayed, + Decl => Signal, + Sig => Sig, + Instance => Instance, + Time => T, + Prefix => Prefix)); + end Elaborate_Delayed_Signal; + + procedure Elaborate_Package (Decl: Iir) + is + Package_Info : constant Sim_Info_Acc := Get_Info (Decl); + Instance : Block_Instance_Acc; + begin + Instance := new Block_Instance_Type' + (Max_Objs => Package_Info.Nbr_Objects, + Scope_Level => Package_Info.Frame_Scope_Level, + Up_Block => null, + Label => Decl, + Stmt => Null_Iir, + Parent => null, + Children => null, + Brother => null, + Marker => Empty_Marker, + Objects => (others => null), + Elab_Objects => 0, + In_Wait_Flag => False, + Actuals_Ref => null, + Result => null); + + Package_Instances (Package_Info.Inst_Slot) := Instance; + + if Trace_Elaboration then + Ada.Text_IO.Put_Line ("elaborating " & Disp_Node (Decl)); + end if; + + -- Elaborate objects declarations. + Elaborate_Declarative_Part (Instance, Get_Declaration_Chain (Decl)); + end Elaborate_Package; + + procedure Elaborate_Package_Body (Decl: Iir) + is + Package_Info : constant Sim_Info_Acc := Get_Info (Decl); + Instance : Block_Instance_Acc; + begin + Instance := Package_Instances + (Instance_Slot_Type (-Package_Info.Frame_Scope_Level)); + + if Trace_Elaboration then + Ada.Text_IO.Put_Line ("elaborating " & Disp_Node (Decl)); + end if; + + -- Elaborate objects declarations. + Elaborate_Declarative_Part (Instance, Get_Declaration_Chain (Decl)); + end Elaborate_Package_Body; + + -- Elaborate all packages which DESIGN_UNIT depends on. + -- The packages are elaborated only once. The body, if the package needs + -- one, can be loaded during the elaboration. + -- Recursive function. + -- FIXME: handle pathological cases of recursion. + -- Due to the rules of analysis, it is not possible to have a circulare + -- dependence. + procedure Elaborate_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_Entity_Aspect_Entity then + -- During Sem, the architecture may be still unknown, and the + -- dependency is therefore the aspect. + Library_Unit := Get_Architecture (Design); + Design := Get_Design_Unit (Library_Unit); + else + Library_Unit := Get_Library_Unit (Design); + end if; + -- Elaborates only non-elaborated packages. + case Get_Kind (Library_Unit) is + when Iir_Kind_Package_Declaration => + declare + Info : constant Sim_Info_Acc := Get_Info (Library_Unit); + Body_Design: Iir_Design_Unit; + begin + if Package_Instances (Info.Inst_Slot) = null then + -- Package not yet elaborated. + + -- Load the body now, as it can add objects in the + -- package instance. + Body_Design := Libraries.Load_Secondary_Unit + (Design, Null_Identifier, Design_Unit); + + -- First the packages on which DESIGN depends. + Elaborate_Dependence (Design); + + -- Then the declaration. + Elaborate_Package (Library_Unit); + + -- And then the body (if any). + if Body_Design = Null_Iir then + if Get_Need_Body (Library_Unit) then + Error_Msg_Elab + ("no package body for `" & + Image_Identifier (Library_Unit) & '''); + end if; + else + -- Note: the body can elaborate some packages. + Elaborate_Dependence (Body_Design); + + Elaborate_Package_Body + (Get_Library_Unit (Body_Design)); + end if; + end if; + end; + when Iir_Kind_Entity_Declaration + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Architecture_Body => + Elaborate_Dependence (Design); + when others => + Error_Kind ("elaborate_dependence", Library_Unit); + end case; + end loop; + end Elaborate_Dependence; + + -- Create a block instance to instantiate OBJ (block, component, + -- architecture, generate) in FATHER. STMT is the statement/declaration + -- at the origin of the instantiation (it is generally the same as OBJ, + -- except for component where STMT is the component instantation + -- statement). + function Create_Block_Instance + (Father : Block_Instance_Acc; + Obj : Iir; + Stmt : Iir) + return Block_Instance_Acc + is + Obj_Info : constant Sim_Info_Acc := Get_Info (Obj); + Res : Block_Instance_Acc; + begin + Res := new Block_Instance_Type' + (Max_Objs => Obj_Info.Nbr_Objects, + Scope_Level => Obj_Info.Frame_Scope_Level, + Up_Block => Father, + Label => Stmt, + Stmt => Obj, + Parent => Father, + Children => null, + Brother => null, + Marker => Empty_Marker, + Objects => (others => null), + Elab_Objects => 0, + In_Wait_Flag => False, + Actuals_Ref => null, + Result => null); + + if Father /= null then + Res.Brother := Father.Children; + Father.Children := Res; + end if; + + return Res; + end Create_Block_Instance; + + function Create_Protected_Object (Block: Block_Instance_Acc; Decl: Iir) + return Iir_Value_Literal_Acc + is + Bod : constant Iir := Get_Protected_Type_Body (Decl); + Inst : Block_Instance_Acc; + Res : Iir_Value_Literal_Acc; + begin + Protected_Table.Increment_Last; + Res := Create_Protected_Value (Protected_Table.Last); + + Inst := Create_Subprogram_Instance (Block, Bod); + Protected_Table.Table (Res.Prot) := Inst; + + -- Temporary put the instancce on the stack in case of function calls + -- during the elaboration of the protected object. + Current_Process.Instance := Inst; + + Elaborate_Declarative_Part (Inst, Get_Declaration_Chain (Bod)); + + Current_Process.Instance := Block; + + return Res; + end Create_Protected_Object; + + -- Create an value_literal for DECL (defined in BLOCK) and set it with + -- its default values. Nodes are shared. + function Create_Value_For_Type + (Block: Block_Instance_Acc; Decl: Iir; Default : Boolean) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + Bounds : Iir_Value_Literal_Acc; + begin + case Get_Kind (Decl) is + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Integer_Type_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Floating_Type_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Physical_Type_Definition => + if Default then + Bounds := Execute_Bounds (Block, Decl); + Res := Bounds.Left; + else + case Get_Info (Get_Base_Type (Decl)).Scalar_Mode is + when Iir_Value_B1 => + Res := Create_B1_Value (False); + when Iir_Value_E32 => + Res := Create_E32_Value (0); + when Iir_Value_I64 => + Res := Create_I64_Value (0); + when Iir_Value_F64 => + Res := Create_F64_Value (0.0); + when others => + raise Internal_Error; + end case; + end if; + + when Iir_Kind_Array_Subtype_Definition => + Res := Create_Array_Bounds_From_Type (Block, Decl, True); + declare + El : Iir_Value_Literal_Acc; + begin + if Res.Val_Array.Len > 0 then + El := Create_Value_For_Type + (Block, Get_Element_Subtype (Decl), Default); + Res.Val_Array.V (1) := El; + for I in 2 .. Res.Val_Array.Len loop + Res.Val_Array.V (I) := El; + end loop; + end if; + end; + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + declare + El : Iir_Element_Declaration; + List : constant Iir_List := + Get_Elements_Declaration_List (Get_Base_Type (Decl)); + begin + Res := Create_Record_Value + (Iir_Index32 (Get_Nbr_Elements (List))); + + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Res.Val_Record.V (1 + Get_Element_Position (El)) := + Create_Value_For_Type (Block, Get_Type (El), Default); + end loop; + end; + when Iir_Kind_Access_Type_Definition + | Iir_Kind_Access_Subtype_Definition => + return Create_Access_Value (null); + when Iir_Kind_Protected_Type_Declaration => + return Create_Protected_Object (Block, Decl); + when others => + Error_Kind ("create_value_for_type", Decl); + end case; + return Res; + end Create_Value_For_Type; + + procedure Create_Object (Instance : Block_Instance_Acc; Decl : Iir) + is + Slot : constant Object_Slot_Type := Get_Info (Decl).Slot; + begin + -- Check elaboration order. + -- Note: this is not done for package since objects from package are + -- commons (same scope), and package annotation order can be different + -- from package elaboration order (eg: body). + if Slot /= Instance.Elab_Objects + 1 + or else Instance.Objects (Slot) /= null + then + Error_Msg_Elab ("bad elaboration order"); + raise Internal_Error; + end if; + Instance.Elab_Objects := Slot; + end Create_Object; + + procedure Destroy_Object (Instance : Block_Instance_Acc; Decl : Iir) + is + Info : constant Sim_Info_Acc := Get_Info (Decl); + Slot : constant Object_Slot_Type := Info.Slot; + begin + if Slot /= Instance.Elab_Objects + or else Info.Scope_Level /= Instance.Scope_Level + then + Error_Msg_Elab ("bad destroy order"); + raise Internal_Error; + end if; + -- Clear the slot (this is necessary for ranges). + Instance.Objects (Slot) := null; + Instance.Elab_Objects := Slot - 1; + end Destroy_Object; + + procedure Create_Signal (Instance : Block_Instance_Acc; Decl : Iir) + is + Slot : constant Object_Slot_Type := Get_Info (Decl).Slot; + begin + if Slot /= Instance.Elab_Objects + 1 + or else Instance.Objects (Slot) /= null + then + Error_Msg_Elab ("bad elaboration order"); + raise Internal_Error; + end if; + -- One slot is reserved for default value + Instance.Elab_Objects := Slot + 1; + end Create_Signal; + + function Create_Terminal_Object (Block: Block_Instance_Acc; + Decl : Iir; + Def: Iir) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + begin + case Get_Kind (Def) is + when Iir_Kind_Scalar_Nature_Definition => + Res := Create_Terminal_Value + (Create_Scalar_Terminal (Decl, Block)); + when others => + Error_Kind ("create_terminal_object", Def); + end case; + return Res; + end Create_Terminal_Object; + + procedure Create_Terminal (Instance : Block_Instance_Acc; Decl : Iir) + is + Slot : constant Object_Slot_Type := Get_Info (Decl).Slot; + begin + if Slot + 1 = Instance.Elab_Objects then + -- Reference terminal of nature declaration may have already been + -- elaborated. + return; + end if; + if Slot /= Instance.Elab_Objects then + Error_Msg_Elab ("bad elaboration order"); + raise Internal_Error; + end if; + Instance.Objects (Slot) := + Create_Terminal_Object (Instance, Decl, Get_Nature (Decl)); + Instance.Elab_Objects := Slot + 1; + end Create_Terminal; + + function Create_Quantity_Object (Block: Block_Instance_Acc; + Decl : Iir; + Def: Iir) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + Kind : Quantity_Kind; + begin + case Get_Kind (Def) is + when Iir_Kind_Floating_Type_Definition + | Iir_Kind_Floating_Subtype_Definition => + case Iir_Kinds_Quantity_Declaration (Get_Kind (Decl)) is + when Iir_Kind_Across_Quantity_Declaration => + Kind := Quantity_Across; + when Iir_Kind_Through_Quantity_Declaration => + Kind := Quantity_Through; + when Iir_Kind_Free_Quantity_Declaration => + Kind := Quantity_Free; + end case; + Res := Create_Quantity_Value + (Create_Scalar_Quantity (Kind, Decl, Block)); + when others => + Error_Kind ("create_quantity_object", Def); + end case; + return Res; + end Create_Quantity_Object; + + function Create_Quantity (Instance : Block_Instance_Acc; Decl : Iir) + return Iir_Value_Literal_Acc + is + Slot : constant Object_Slot_Type := Get_Info (Decl).Slot; + Res : Iir_Value_Literal_Acc; + begin + if Slot /= Instance.Elab_Objects then + Error_Msg_Elab ("bad elaboration order"); + raise Internal_Error; + end if; + Res := Create_Quantity_Object (Instance, Decl, Get_Type (Decl)); + Instance.Objects (Slot) := Res; + Instance.Elab_Objects := Slot + 1; + return Res; + end Create_Quantity; + + function Elaborate_Bound_Constraint + (Instance : Block_Instance_Acc; Bound: Iir) + return Iir_Value_Literal_Acc + is + Value : Iir_Value_Literal_Acc; + Ref : constant Iir := Get_Type (Bound); + Res : Iir_Value_Literal_Acc; + begin + Res := Create_Value_For_Type (Instance, Ref, False); + Res := Unshare (Res, Instance_Pool); + Value := Execute_Expression (Instance, Bound); + Assign_Value_To_Object (Instance, Res, Ref, Value, Bound); + return Res; + end Elaborate_Bound_Constraint; + + procedure Elaborate_Range_Expression + (Instance : Block_Instance_Acc; Rc: Iir_Range_Expression) + is + Range_Info : constant Sim_Info_Acc := Get_Info (Rc); + Val : Iir_Value_Literal_Acc; + begin + if Range_Info.Scope_Level /= Instance.Scope_Level + or else Instance.Objects (Range_Info.Slot) /= null + then + -- A range expression may have already been created, for example + -- when severals objects are created with the same subtype: + -- variable v, v1 : bit_vector (x to y); + return; + end if; + if False + and then (Range_Info.Scope_Level /= Instance.Scope_Level + or else Range_Info.Slot < Instance.Elab_Objects) + then + -- FIXME: the test is wrong for packages. + -- The range was already elaborated. + -- ?? Is that possible + raise Internal_Error; + return; + end if; + Create_Object (Instance, Rc); + Val := Create_Range_Value + (Elaborate_Bound_Constraint (Instance, Get_Left_Limit (Rc)), + Elaborate_Bound_Constraint (Instance, Get_Right_Limit (Rc)), + Get_Direction (Rc)); + Instance.Objects (Range_Info.Slot) := Unshare (Val, Instance_Pool); + end Elaborate_Range_Expression; + + procedure Elaborate_Range_Constraint + (Instance : Block_Instance_Acc; Rc: Iir) + is + begin + case Get_Kind (Rc) is + when Iir_Kind_Range_Expression => + Elaborate_Range_Expression (Instance, Rc); + when Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute => + null; + when others => + Error_Kind ("elaborate_range_constraint", Rc); + end case; + end Elaborate_Range_Constraint; + + -- Create the bounds of a scalar type definition. + -- Elaborate_Range_Constraint cannot be used, as it checks bounds (and + -- here we create the bounds). + procedure Elaborate_Type_Range + (Instance : Block_Instance_Acc; Rc: Iir_Range_Expression) + is + Range_Info : Sim_Info_Acc; + Val : Iir_Value_Literal_Acc; + begin + Range_Info := Get_Info (Rc); + Create_Object (Instance, Rc); + Val := Create_Range_Value + (Execute_Expression (Instance, Get_Left_Limit (Rc)), + Execute_Expression (Instance, Get_Right_Limit (Rc)), + Get_Direction (Rc)); + Instance.Objects (Range_Info.Slot) := Unshare (Val, Instance_Pool); + end Elaborate_Type_Range; + + -- DECL is a subtype indication. + -- Elaborate DECL only if it is anonymous. + procedure Elaborate_Subtype_Indication_If_Anonymous + (Instance : Block_Instance_Acc; Decl : Iir) is + begin + if Is_Anonymous_Type_Definition (Decl) then + Elaborate_Subtype_Indication (Instance, Decl); + end if; + end Elaborate_Subtype_Indication_If_Anonymous; + + -- LRM93 §12.3.1.3 Subtype Declarations + -- The elaboration of a subtype indication creates a subtype. + procedure Elaborate_Subtype_Indication + (Instance : Block_Instance_Acc; Ind : Iir) + is + begin + case Get_Kind (Ind) is + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Array_Type_Definition + | Iir_Kind_File_Type_Definition + | Iir_Kind_Access_Type_Definition + | Iir_Kind_Record_Type_Definition => + Elaborate_Type_Definition (Instance, Ind); + when Iir_Kind_Array_Subtype_Definition => + -- LRM93 12.3.1.3 + -- The elaboration of an index constraint consists of the + -- declaration of each of the discrete ranges in the index + -- constraint in some order that is not defined by the language. + declare + St_Indexes : constant Iir_List := Get_Index_Subtype_List (Ind); + St_El : Iir; + begin + for I in Natural loop + St_El := Get_Index_Type (St_Indexes, I); + exit when St_El = Null_Iir; + Elaborate_Subtype_Indication_If_Anonymous (Instance, St_El); + end loop; + Elaborate_Subtype_Indication_If_Anonymous + (Instance, Get_Element_Subtype (Ind)); + end; + when Iir_Kind_Record_Subtype_Definition => + null; + when Iir_Kind_Access_Subtype_Definition => + null; + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + Elaborate_Range_Constraint (Instance, Get_Range_Constraint (Ind)); + when Iir_Kind_Physical_Subtype_Definition => + Elaborate_Range_Constraint (Instance, Get_Range_Constraint (Ind)); + when others => + Error_Kind ("elaborate_subtype_indication", Ind); + end case; + end Elaborate_Subtype_Indication; + + -- LRM93 §12.3.1.2 Type Declarations. + procedure Elaborate_Type_Definition + (Instance : Block_Instance_Acc; Def : Iir) + is + begin + case Get_Kind (Def) is + when Iir_Kind_Enumeration_Type_Definition => + -- Elaboration of an enumeration type definition has not effect + -- other than the creation of the corresponding type. + Elaborate_Type_Range (Instance, Get_Range_Constraint (Def)); + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Floating_Type_Definition + | Iir_Kind_Physical_Type_Definition => + null; + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition => + -- Elaboration of an integer, floating point, or physical type + -- definition consists of the elaboration of the corresponding + -- range constraint. + Elaborate_Subtype_Indication_If_Anonymous (Instance, Def); + -- Elaboration of a physical unit declaration has no effect other + -- than to create the unit defined by the unit declaration. + null; + when Iir_Kind_Array_Type_Definition => + -- Elaboration of an unconstrained array type definition consists + -- of the elaboration of the element subtype indication of the + -- array type. + Elaborate_Subtype_Indication_If_Anonymous + (Instance, Get_Element_Subtype (Def)); + when Iir_Kind_Access_Type_Definition => + -- Elaboration of an access type definition consists of the + -- elaboration of the corresponding subtype indication. + Elaborate_Subtype_Indication_If_Anonymous + (Instance, Get_Designated_Type (Def)); + when Iir_Kind_File_Type_Definition => + -- GHDL: There is nothing about elaboration of a file type + -- definition. FIXME ?? + null; + when Iir_Kind_Record_Type_Definition => + -- Elaboration of a record type definition consists of the + -- elaboration of the equivalent single element declarations in + -- the given order. + declare + El : Iir_Element_Declaration; + List : Iir_List; + begin + List := Get_Elements_Declaration_List (Def); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + -- Elaboration of an element declaration consists of + -- elaboration of the element subtype indication. + Elaborate_Subtype_Indication_If_Anonymous + (Instance, Get_Type (El)); + end loop; + end; + when Iir_Kind_Protected_Type_Declaration => + Elaborate_Declarative_Part + (Instance, Get_Declaration_Chain (Def)); + + when Iir_Kind_Incomplete_Type_Definition => + null; + when others => + Error_Kind ("elaborate_type_definition", Def); + end case; + end Elaborate_Type_Definition; + + -- LRM93 §12.3.1.2 Type Declarations. + procedure Elaborate_Type_Declaration + (Instance : Block_Instance_Acc; Decl : Iir_Type_Declaration) + is + Def : Iir; + Base_Type : Iir_Array_Type_Definition; + begin + -- Elaboration of a type declaration generally consists of the + -- elaboration of the definition of the type and the creation of that + -- type. + Def := Get_Type_Definition (Decl); + if Def = Null_Iir then + -- FIXME: can this happen ? + raise Program_Error; + end if; + if Get_Kind (Def) = Iir_Kind_Array_Subtype_Definition then + Base_Type := Get_Base_Type (Def); + -- For a constrained array type declaration, however, + -- elaboration consists of the elaboration of the equivalent + -- anonymous unconstrained array type [...] + Elaborate_Subtype_Indication_If_Anonymous (Instance, Base_Type); + -- [...] followed by the elaboration of the named subtype + -- of that unconstrained type. + Elaborate_Subtype_Indication (Instance, Def); + else + Elaborate_Type_Definition (Instance, Def); + end if; + end Elaborate_Type_Declaration; + + procedure Elaborate_Nature_Definition + (Instance : Block_Instance_Acc; Def : Iir) + is + begin + case Get_Kind (Def) is + when Iir_Kind_Scalar_Nature_Definition => + Elaborate_Subtype_Indication (Instance, Get_Across_Type (Def)); + Elaborate_Subtype_Indication (Instance, Get_Through_Type (Def)); + when others => + Error_Kind ("elaborate_nature_definition", Def); + end case; + end Elaborate_Nature_Definition; + + -- LRM93 §12.2.1 The Generic Clause + procedure Elaborate_Generic_Clause + (Instance : Block_Instance_Acc; Generic_Chain : Iir) + is + Decl : Iir_Constant_Interface_Declaration; + begin + -- Elaboration of a generic clause consists of the elaboration of each + -- of the equivalent single generic declarations contained in the + -- clause, in the order given. + Decl := Generic_Chain; + while Decl /= Null_Iir loop + -- The elaboration of a generic declaration consists of elaborating + -- the subtype indication and then creating a generic constant of + -- that subtype. + Elaborate_Subtype_Indication_If_Anonymous (Instance, Get_Type (Decl)); + Create_Object (Instance, Decl); + -- The value of a generic constant is not defined until a subsequent + -- generic map aspect is evaluated, or in the absence of a generic + -- map aspect, until the default expression associated with the + -- generic constant is evaluated to determine the value of the + -- constant. + Decl := Get_Chain (Decl); + end loop; + end Elaborate_Generic_Clause; + + -- LRM93 12.2.3 The Port Clause + procedure Elaborate_Port_Clause + (Instance : Block_Instance_Acc; Port_Chain : Iir) + is + Decl : Iir_Signal_Interface_Declaration; + begin + Decl := Port_Chain; + while Decl /= Null_Iir loop + -- LRM93 §12.2.3 + -- The elaboration of a port declaration consists of elaborating the + -- subtype indication and then creating a port of that subtype. + Elaborate_Subtype_Indication_If_Anonymous (Instance, Get_Type (Decl)); + + -- Simply increase an index to check that the port was created. + Create_Signal (Instance, Decl); + + Decl := Get_Chain (Decl); + end loop; + end Elaborate_Port_Clause; + + -- LRM93 §12.2.2 The generic Map Aspect + procedure Elaborate_Generic_Map_Aspect + (Target_Instance : Block_Instance_Acc; + Local_Instance : Block_Instance_Acc; + Map : Iir) + is + Assoc : Iir; + Inter : Iir_Constant_Interface_Declaration; + Value : Iir; + Val : Iir_Value_Literal_Acc; + Last_Individual : Iir_Value_Literal_Acc; + begin + -- Elaboration of a generic map aspect consists of elaborating the + -- generic association list. + + -- Elaboration of a generic association list consists of the + -- elaboration of each generic association element in the + -- association list. + Assoc := Map; + while Assoc /= Null_Iir loop + -- Elaboration of a generic association element consists of the + -- elaboration of the formal part and the evaluation of the actual + -- part. + -- FIXME: elaboration of the formal part. + Inter := Get_Association_Interface (Assoc); + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_Open => + -- The generic association list contains an implicit + -- association element for each generic constant that is not + -- explicitly associated with an actual [GHDL: done trought + -- annotations] or that is associated with the reserved word + -- OPEN; the actual part of such an implicit association + -- element is the default expression appearing in the + -- declaration of that generic constant. + Value := Get_Default_Value (Inter); + if Value = Null_Iir then + Error_Msg_Exec ("no default value", Inter); + return; + end if; + Val := Execute_Expression (Target_Instance, Value); + when Iir_Kind_Association_Element_By_Expression => + Value := Get_Actual (Assoc); + Val := Execute_Expression (Local_Instance, Value); + when Iir_Kind_Association_Element_By_Individual => + Val := Create_Value_For_Type + (Local_Instance, Get_Actual_Type (Assoc), False); + + Last_Individual := Unshare (Val, Instance_Pool); + Target_Instance.Objects (Get_Info (Inter).Slot) := + Last_Individual; + goto Continue; + when others => + Error_Kind ("elaborate_generic_map_aspect", Assoc); + end case; + + if Get_Whole_Association_Flag (Assoc) then + -- It is an error if the value of the actual does not belong to + -- the subtype denoted by the subtype indication of the formal. + -- If the subtype denoted by the subtype indication of the + -- declaration of the formal is a constrained array subtype, then + -- an implicit subtype conversion is performed prior to this + -- check. + -- It is also an error if the type of the formal is an array type + -- and the value of each element of the actual does not belong to + -- the element subtype of the formal. + Implicit_Array_Conversion + (Target_Instance, Val, Get_Type (Inter), Inter); + Check_Constraints (Target_Instance, Val, Get_Type (Inter), Inter); + + -- The generic constant or subelement or slice thereof designated + -- by the formal part is then initialized with the value + -- resulting from the evaluation of the corresponding actual part. + Target_Instance.Objects (Get_Info (Inter).Slot) := + Unshare (Val, Instance_Pool); + else + declare + Targ : Iir_Value_Literal_Acc; + Is_Sig : Boolean; + begin + Execute_Name_With_Base + (Target_Instance, Get_Formal (Assoc), + Last_Individual, Targ, Is_Sig); + Store (Targ, Val); + end; + end if; + + <<Continue>> null; + Assoc := Get_Chain (Assoc); + end loop; + end Elaborate_Generic_Map_Aspect; + + -- Return TRUE if EXPR is a signal name. + function Is_Signal (Expr : Iir) return Boolean + is + Obj : Iir; + begin + Obj := Sem_Names.Name_To_Object (Expr); + if Obj /= Null_Iir then + return Is_Signal_Object (Obj); + else + return False; + end if; + end Is_Signal; + + -- LRM93 12.2.3 The Port Clause + procedure Elaborate_Port_Declaration + (Instance : Block_Instance_Acc; + Decl : Iir_Signal_Interface_Declaration; + Default_Value : Iir_Value_Literal_Acc) + is + Val : Iir_Value_Literal_Acc; + begin + if Default_Value = null then + Val := Elaborate_Default_Value (Instance, Decl); + else + Val := Default_Value; + end if; + Elaborate_Signal (Instance, Decl, Val); + end Elaborate_Port_Declaration; + + procedure Elab_Connect + (Formal_Instance : Block_Instance_Acc; + Local_Instance : Block_Instance_Acc; + Actual_Expr : Iir_Value_Literal_Acc; + Assoc : Iir_Association_Element_By_Expression) + is + Inter : Iir; + Actual : Iir; + Local_Expr : Iir_Value_Literal_Acc; + Formal_Expr : Iir_Value_Literal_Acc; + begin + Inter := Get_Formal (Assoc); + Actual := Get_Actual (Assoc); + Formal_Expr := Execute_Name (Formal_Instance, Inter, True); + Formal_Expr := Unshare_Bounds (Formal_Expr, Global_Pool'Access); + if Actual_Expr = null then + Local_Expr := Execute_Name (Local_Instance, Actual, True); + Local_Expr := Unshare_Bounds (Local_Expr, Global_Pool'Access); + else + Local_Expr := Actual_Expr; + end if; + + Connect_Table.Append ((Formal => Formal_Expr, + Formal_Instance => Formal_Instance, + Actual => Local_Expr, + Actual_Instance => Local_Instance, + Assoc => Assoc)); + end Elab_Connect; + + -- LRM93 12.2.3 The Port Clause + -- LRM93 §12.2.4 The Port Map Aspect + procedure Elaborate_Port_Map_Aspect + (Formal_Instance : Block_Instance_Acc; + Actual_Instance : Block_Instance_Acc; + Ports : Iir; + Map : Iir) + is + Assoc : Iir; + Inter : Iir_Signal_Interface_Declaration; + Actual_Expr : Iir_Value_Literal_Acc; + Init_Expr : Iir_Value_Literal_Acc; + Actual : Iir; + begin + if Ports = Null_Iir then + return; + end if; + + -- Elaboration of a port map aspect consists of elaborating the port + -- association list. + if Map = Null_Iir then + -- No port association, elaborate the port clause. + -- Elaboration of a port clause consists of the elaboration of each + -- of the equivalent signal port declaration in the clause, in the + -- order given. + Inter := Ports; + while Inter /= Null_Iir loop + Elaborate_Port_Declaration (Formal_Instance, Inter, null); + Inter := Get_Chain (Inter); + end loop; + return; + end if; + + Current_Component := Formal_Instance; + + Assoc := Map; + while Assoc /= Null_Iir loop + -- Elaboration of a port association list consists of the elaboration + -- of each port association element in the association list whose + -- actual is not the reserved word OPEN. + Inter := Get_Association_Interface (Assoc); + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_By_Expression => + if Get_In_Conversion (Assoc) = Null_Iir + and then Get_Out_Conversion (Assoc) = Null_Iir + then + Actual := Get_Actual (Assoc); + if Is_Signal (Actual) then + -- Association with a signal + Init_Expr := Execute_Signal_Init_Value + (Actual_Instance, Actual); + Implicit_Array_Conversion + (Formal_Instance, Init_Expr, Get_Type (Inter), Actual); + Init_Expr := Unshare_Bounds + (Init_Expr, Global_Pool'Access); + Actual_Expr := null; + else + -- Association with an expression + Init_Expr := Execute_Expression + (Actual_Instance, Actual); + Implicit_Array_Conversion + (Formal_Instance, Init_Expr, + Get_Type (Inter), Actual); + Init_Expr := Unshare (Init_Expr, Global_Pool'Access); + Actual_Expr := Init_Expr; + end if; + else + -- The actual doesn't define the constraints of the formal. + if Get_Whole_Association_Flag (Assoc) then + Init_Expr := Elaborate_Default_Value + (Formal_Instance, Inter); + Actual_Expr := null; + end if; + end if; + + if Get_Whole_Association_Flag (Assoc) + and then Get_Collapse_Signal_Flag (Assoc) + then + declare + Slot : constant Object_Slot_Type := + Get_Info (Inter).Slot; + Actual_Sig : Iir_Value_Literal_Acc; + begin + Actual_Sig := + Execute_Name (Actual_Instance, Actual, True); + Implicit_Array_Conversion + (Formal_Instance, Actual_Sig, + Get_Type (Inter), Actual); + Formal_Instance.Objects (Slot) := Unshare_Bounds + (Actual_Sig, Global_Pool'Access); + Formal_Instance.Objects (Slot + 1) := Init_Expr; + end; + else + if Get_Whole_Association_Flag (Assoc) then + Elaborate_Signal (Formal_Instance, Inter, Init_Expr); + end if; + + -- Elaboration of a port association element consists of the + -- elaboration of the formal part; the port or subelement + -- or slice thereof designated by the formal part is then + -- associated with the signal or expression designated + -- by the actual part. + Elab_Connect + (Formal_Instance, Actual_Instance, Actual_Expr, Assoc); + end if; + + when Iir_Kind_Association_Element_Open => + -- Note that an open cannot be associated with a formal that + -- is associated individually. + Elaborate_Port_Declaration (Formal_Instance, Inter, null); + + when Iir_Kind_Association_Element_By_Individual => + Init_Expr := Create_Value_For_Type + (Formal_Instance, Get_Actual_Type (Assoc), False); + Elaborate_Signal (Formal_Instance, Inter, Init_Expr); + + when others => + Error_Kind ("elaborate_port_map_aspect", Assoc); + end case; + Assoc := Get_Chain (Assoc); + end loop; + + Current_Component := null; + end Elaborate_Port_Map_Aspect; + + -- LRM93 §12.2 Elaboration of a block header + -- Elaboration of a block header consists of the elaboration of the + -- generic clause, the generic map aspect, the port clause, and the port + -- map aspect, in that order. + procedure Elaborate_Block_Header + (Instance : Block_Instance_Acc; Header : Iir_Block_Header) + is + begin + Elaborate_Generic_Clause (Instance, Get_Generic_Chain (Header)); + Elaborate_Generic_Map_Aspect + (Instance, Instance, Get_Generic_Map_Aspect_Chain (Header)); + Elaborate_Port_Clause (Instance, Get_Port_Chain (Header)); + Elaborate_Port_Map_Aspect + (Instance, Instance, + Get_Port_Chain (Header), Get_Port_Map_Aspect_Chain (Header)); + end Elaborate_Block_Header; + + procedure Elaborate_Guard_Signal + (Instance : Block_Instance_Acc; Guard : Iir) + is + Sig : Iir_Value_Literal_Acc; + Info : constant Sim_Info_Acc := Get_Info (Guard); + begin + Create_Signal (Instance, Guard); + + Sig := Create_Signal_Value (null); + Instance.Objects (Info.Slot) := Sig; + Instance.Objects (Info.Slot + 1) := + Unshare (Create_B1_Value (False), Instance_Pool); + + Signals_Table.Append ((Kind => Guard_Signal, + Decl => Guard, + Sig => Sig, + Instance => Instance)); + end Elaborate_Guard_Signal; + + -- LRM93 §12.4.1 Block statements. + procedure Elaborate_Block_Statement + (Instance : Block_Instance_Acc; Block : Iir_Block_Statement) + is + Header : Iir_Block_Header; + Ninstance : Block_Instance_Acc; -- FIXME + Guard : Iir; + begin + Ninstance := Create_Block_Instance (Instance, Block, Block); + + Guard := Get_Guard_Decl (Block); + if Guard /= Null_Iir then + -- LRM93 12.6.4 (3) + -- The value of each implicit GUARD signal is set to the result of + -- evaluating the corresponding guard expression. + -- GHDL: done by grt when the guard signal is created. + Elaborate_Guard_Signal (Ninstance, Guard); + end if; + + -- Elaboration of a block statement consists of the elaboration of the + -- block header, if present [...] + Header := Get_Block_Header (Block); + if Header /= Null_Iir then + Elaborate_Block_Header (Ninstance, Header); + end if; + + -- [...] followed by the elaboration of the block declarative part [...] + Elaborate_Declarative_Part (Ninstance, + Get_Declaration_Chain (Block)); + -- [...] followed by the elaboration of the block statement part. + Elaborate_Statement_Part + (Ninstance, Get_Concurrent_Statement_Chain (Block)); + -- Elaboration of a block statement may occur under the control of a + -- configuration declaration. + -- In particular, a block configuration, wether implicit or explicit, + -- within a configuration declaration may supply a sequence of + -- additionnal implicit configuration specification to be applied + -- during the elaboration of the corresponding block statement. + -- If a block statement is being elaborated under the control of a + -- configuration declaration, then the sequence of implicit + -- configuration specifications supplied by the block configuration + -- is elaborated as part of the block declarative part, following all + -- other declarative items in that part. + -- The sequence of implicit configuration specifications supplied by a + -- block configuration, wether implicit or explicit, consists of each of + -- the configuration specifications implied by component configurations + -- occurring immediatly within the block configuration, and in the + -- order in which the component configurations themselves appear. + -- FIXME. + end Elaborate_Block_Statement; + + function Create_Default_Association (Formal_Chain : Iir; + Local_Chain : Iir; + Node : Iir) + return Iir + is + Nbr_Formals : Natural; + begin + -- LRM93 5.2.2 + -- The default binding indication includes a default generic map + -- aspect if the design entity implied by the entity aspect contains + -- formal generic. + -- + -- LRM93 5.2.2 + -- The default binding indication includes a default port map aspect if + -- the design entity implied by the entity aspect contains formal ports. + if Formal_Chain = Null_Iir then + if Local_Chain /= Null_Iir then + Error_Msg_Sem ("cannot create default map aspect", Node); + end if; + return Null_Iir; + end if; + Nbr_Formals := Get_Chain_Length (Formal_Chain); + declare + Assoc_List : Iir_Array (0 .. Nbr_Formals - 1) := (others => Null_Iir); + Assoc : Iir; + Local : Iir; + Formal : Iir; + Pos : Natural; + First, Last : Iir; + begin + -- LRM93 5.2.2 + -- The default generic map aspect associates each local generic in + -- the corresponding component instantiation (if any) with a formal + -- of the same simple name. + Local := Local_Chain; + while Local /= Null_Iir loop + Formal := Formal_Chain; + Pos := 0; + while Formal /= Null_Iir loop + exit when Get_Identifier (Formal) = Get_Identifier (Local); + Formal := Get_Chain (Formal); + Pos := Pos + 1; + end loop; + if Formal = Null_Iir then + -- LRM93 5.2.2 + -- It is an error if such a formal does not exist, or if + -- its mode and type are not appropriate for such an + -- association. + -- FIXME: mode/type check. + Error_Msg_Sem + ("cannot associate local " & Disp_Node (Local), Node); + exit; + end if; + if Assoc_List (Pos) /= Null_Iir then + raise Internal_Error; + end if; + Assoc_List (Pos) := Local; + + Local := Get_Chain (Local); + end loop; + + Sub_Chain_Init (First, Last); + Formal := Formal_Chain; + for I in Assoc_List'Range loop + if Assoc_List (I) = Null_Iir then + -- LRM93 5.2.2 + -- Any remaining unassociated formals are associated with the + -- actual designator any. + Assoc := Create_Iir (Iir_Kind_Association_Element_Open); + else + Assoc := + Create_Iir (Iir_Kind_Association_Element_By_Expression); + Set_Actual (Assoc, Assoc_List (I)); + end if; + Set_Whole_Association_Flag (Assoc, True); + Set_Formal (Assoc, Formal); + Sub_Chain_Append (First, Last, Assoc); + + Formal := Get_Chain (Formal); + end loop; + return First; + end; + end Create_Default_Association; + + -- LRM93 §12.4.3 + function Is_Fully_Bound (Conf : Iir) return Boolean + is + Binding : Iir; + begin + if Conf = Null_Iir then + return False; + end if; + case Get_Kind (Conf) is + when Iir_Kind_Configuration_Specification + | Iir_Kind_Component_Configuration => + Binding := Get_Binding_Indication (Conf); + if Binding = Null_Iir then + return False; + end if; + if Get_Kind (Get_Entity_Aspect (Binding)) + = Iir_Kind_Entity_Aspect_Open + then + return False; + end if; + when others => + null; + end case; + return True; + end Is_Fully_Bound; + + procedure Elaborate_Component_Instantiation + (Instance : Block_Instance_Acc; + Stmt : Iir_Component_Instantiation_Statement) + is + Frame : Block_Instance_Acc; + begin + if Is_Component_Instantiation (Stmt) then + declare + Component : constant Iir := + Get_Named_Entity (Get_Instantiated_Unit (Stmt)); + begin + -- Elaboration of a component instantiation statement that + -- instanciates a component declaration has no effect unless the + -- component instance is either fully bound to a design entity + -- defined by an entity declaration and architecture body or is + -- bound to a configuration of such a design entity. + -- FIXME: in fact the component is created. + + -- If a component instance is so bound, then elaboration of the + -- corresponding component instantiation statement consists of the + -- elaboration of the implied block statement representing the + -- component instance and [...] + Frame := Create_Block_Instance (Instance, Component, Stmt); + + Elaborate_Generic_Clause (Frame, Get_Generic_Chain (Component)); + Elaborate_Generic_Map_Aspect + (Frame, Instance, Get_Generic_Map_Aspect_Chain (Stmt)); + Elaborate_Port_Clause (Frame, Get_Port_Chain (Component)); + Elaborate_Port_Map_Aspect + (Frame, Instance, + Get_Port_Chain (Component), Get_Port_Map_Aspect_Chain (Stmt)); + end; + else + -- Direct instantiation + declare + Aspect : constant Iir := Get_Instantiated_Unit (Stmt); + Arch : Iir; + Config : Iir; + begin + case Get_Kind (Aspect) is + when Iir_Kind_Entity_Aspect_Entity => + Arch := Get_Architecture (Aspect); + if Arch = Null_Iir then + Arch := Libraries.Get_Latest_Architecture + (Get_Entity (Aspect)); + end if; + Config := Get_Library_Unit + (Get_Default_Configuration_Declaration (Arch)); + when Iir_Kind_Entity_Aspect_Configuration => + Config := Get_Configuration (Aspect); + Arch := Get_Block_Specification + (Get_Block_Configuration (Config)); + when Iir_Kind_Entity_Aspect_Open => + return; + when others => + raise Internal_Error; + end case; + Config := Get_Block_Configuration (Config); + + Frame := Elaborate_Architecture + (Arch, Config, Instance, Stmt, + Get_Generic_Map_Aspect_Chain (Stmt), + Get_Port_Map_Aspect_Chain (Stmt)); + end; + end if; + end Elaborate_Component_Instantiation; + + -- LRM93 12.4.2 Generate Statements + procedure Elaborate_Conditional_Generate_Statement + (Instance : Block_Instance_Acc; Generate : Iir_Generate_Statement) + is + Scheme : Iir; + Ninstance : Block_Instance_Acc; + Lit : Iir_Value_Literal_Acc; + begin + -- LRM93 12.4.2 + -- For a generate statement with an if generation scheme, elaboration + -- consists of the evaluation of the boolean expression, followed by + -- the generation of exactly one block statement if the expression + -- evaluates to TRUE, and no block statement otherwise. + Scheme := Get_Generation_Scheme (Generate); + Lit := Execute_Expression (Instance, Scheme); + if Lit.B1 /= True then + return; + end if; + + -- LRM93 12.4.2 + -- If generated, the block statement has the following form: + -- 1. The block label is the same as the label of the generate + -- statement. + -- 2. The block declarative part consists of a copy of the declarative + -- items contained within the generate statement. + -- 3. The block statement part consists of a copy of the concurrent + -- statement contained within the generate statement. + Ninstance := Create_Block_Instance (Instance, Generate, Generate); + Elaborate_Declarative_Part (Ninstance, Get_Declaration_Chain (Generate)); + Elaborate_Statement_Part + (Ninstance, Get_Concurrent_Statement_Chain (Generate)); + end Elaborate_Conditional_Generate_Statement; + + -- LRM93 12.4.2 Generate Statements + procedure Elaborate_Iterative_Generate_Statement + (Instance : Block_Instance_Acc; Generate : Iir_Generate_Statement) + is + Scheme : constant Iir_Iterator_Declaration := + Get_Generation_Scheme (Generate); + Ninstance : Block_Instance_Acc; + Sub_Instance : Block_Instance_Acc; + Bound, Index : Iir_Value_Literal_Acc; + begin + -- LRM93 12.4.2 + -- For a generate statement with a for generation scheme, elaboration + -- consists of the elaboration of the discrete range + + Ninstance := Create_Block_Instance (Instance, Generate, Generate); + Elaborate_Declaration (Ninstance, Scheme); + Bound := Execute_Bounds (Ninstance, Get_Type (Scheme)); + + -- Index is the iterator value. + Index := Unshare (Ninstance.Objects (Get_Info (Scheme).Slot), + Current_Pool); + + -- Initialize the iterator. + Store (Index, Bound.Left); + + if not Is_In_Range (Index, Bound) then + -- Well, this instance should have never been built. + -- Should be destroyed ?? + raise Internal_Error; + return; + end if; + + loop + Sub_Instance := Create_Block_Instance (Ninstance, Generate, Scheme); + + -- FIXME: this is needed to copy iterator type (if any). But this + -- elaborates the subtype several times (what about side effects). + Elaborate_Declaration (Sub_Instance, Scheme); + + -- Store index. + Store (Sub_Instance.Objects (Get_Info (Scheme).Slot), Index); + + Elaborate_Declarative_Part + (Sub_Instance, Get_Declaration_Chain (Generate)); + Elaborate_Statement_Part + (Sub_Instance, Get_Concurrent_Statement_Chain (Generate)); + + Update_Loop_Index (Index, Bound); + exit when not Is_In_Range (Index, Bound); + end loop; + -- FIXME: destroy index ? + end Elaborate_Iterative_Generate_Statement; + + procedure Elaborate_Generate_Statement + (Instance : Block_Instance_Acc; Generate : Iir_Generate_Statement) + is + Scheme : Iir; + begin + Scheme := Get_Generation_Scheme (Generate); + if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then + Elaborate_Iterative_Generate_Statement (Instance, Generate); + else + Elaborate_Conditional_Generate_Statement (Instance, Generate); + end if; + end Elaborate_Generate_Statement; + + procedure Elaborate_Process_Statement + (Instance : Block_Instance_Acc; Stmt : Iir) + is + Proc_Instance : Block_Instance_Acc; + begin + Proc_Instance := Create_Block_Instance (Instance, Stmt, Stmt); + + Processes_Table.Append (Proc_Instance); + + -- Processes aren't elaborated here. They are elaborated + -- just before simulation. + end Elaborate_Process_Statement; + + -- LRM93 §12.4 Elaboration of a Statement Part. + procedure Elaborate_Statement_Part + (Instance : Block_Instance_Acc; Stmt_Chain: Iir) + is + Stmt : Iir; + begin + -- Concurrent statements appearing in the statement part of a block + -- must be elaborated before execution begins. + -- Elaboration of the statement part of a block consists of the + -- elaboration of each concurrent statement in the order given. + Stmt := Stmt_Chain; + while Stmt /= Null_Iir loop + case Get_Kind (Stmt) is + when Iir_Kind_Block_Statement => + Elaborate_Block_Statement (Instance, Stmt); + + when Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement => + Elaborate_Process_Statement (Instance, Stmt); + + when Iir_Kind_Component_Instantiation_Statement => + Elaborate_Component_Instantiation (Instance, Stmt); + + when Iir_Kind_Generate_Statement => + Elaborate_Generate_Statement (Instance, Stmt); + + when Iir_Kind_Simple_Simultaneous_Statement => + Add_Characteristic_Expression + (Explicit, + Build (Op_Plus, + Instance, Get_Simultaneous_Right (Stmt), + Build (Op_Minus, + Instance, Get_Simultaneous_Left (Stmt)))); + + when others => + Error_Kind ("elaborate_statement_part", Stmt); + end case; + Stmt := Get_Chain (Stmt); + end loop; + end Elaborate_Statement_Part; + + -- Compute the default value for declaration DECL, using either + -- DEFAULT_VALUE if not null, or the implicit default value for DECL. + -- DECL must have a type. + function Elaborate_Default_Value (Instance : Block_Instance_Acc; Decl : Iir) + return Iir_Value_Literal_Acc + is + Default_Value : constant Iir := Get_Default_Value (Decl); + Val : Iir_Value_Literal_Acc; + begin + if Default_Value /= Null_Iir then + Val := Execute_Expression_With_Type + (Instance, Default_Value, Get_Type (Decl)); + else + Val := Create_Value_For_Type (Instance, Get_Type (Decl), True); + end if; + return Val; + end Elaborate_Default_Value; + + -- LRM93 §12.3.1.1 Subprogram Declaration and Bodies + procedure Elaborate_Interface_List + (Instance : Block_Instance_Acc; Inter_Chain : Iir) + is + Inter : Iir; + begin + -- elaboration of the parameter interface list + -- this in turn involves the elaboration of the subtype indication of + -- each interface element to determine the subtype of each formal + -- parameter of the subprogram. + Inter := Inter_Chain; + while Inter /= Null_Iir loop + case Get_Kind (Inter) is + when Iir_Kind_Signal_Interface_Declaration + | Iir_Kind_Variable_Interface_Declaration + | Iir_Kind_Constant_Interface_Declaration + | Iir_Kind_File_Interface_Declaration => + Elaborate_Subtype_Indication_If_Anonymous + (Instance, Get_Type (Inter)); + when others => + Error_Kind ("elaborate_interface_list", Inter); + end case; + Inter := Get_Chain (Inter); + end loop; + end Elaborate_Interface_List; + + -- LRM93 §12.3.1.1 Subprogram Declaration and Bodies + procedure Elaborate_Subprogram_Declaration + (Instance : Block_Instance_Acc; Decl : Iir) + is + begin + -- Elaboration of a subprogram declaration involves the elaboration + -- of the parameter interface list of the subprogram declaration; [...] + Elaborate_Interface_List + (Instance, Get_Interface_Declaration_Chain (Decl)); + + -- Elaboration of a subprogram body has no effect other than to + -- establish that the body can, from then on, be used for the + -- execution of calls of the subprogram. + -- FIXME + null; + end Elaborate_Subprogram_Declaration; + + procedure Elaborate_Component_Configuration + (Stmt : Iir_Component_Instantiation_Statement; + Comp_Instance : Block_Instance_Acc; + Conf : Iir_Component_Configuration) + is + Component : constant Iir_Component_Declaration := + Get_Named_Entity (Get_Instantiated_Unit (Stmt)); + Entity : Iir_Entity_Declaration; + Arch_Name : Name_Id; + Arch_Design : Iir_Design_Unit; + Arch : Iir_Architecture_Body; + Arch_Frame : Block_Instance_Acc; + pragma Unreferenced (Arch_Frame); + Generic_Map_Aspect_Chain : Iir; + Port_Map_Aspect_Chain : Iir; + Binding : Iir_Binding_Indication; + Aspect : Iir; + Sub_Conf : Iir; + begin + if Trace_Elaboration then + Ada.Text_IO.Put ("configure component "); + Ada.Text_IO.Put (Name_Table.Image (Get_Label (Stmt))); + Ada.Text_IO.Put (": "); + Ada.Text_IO.Put_Line (Image_Identifier (Component)); + end if; + + -- Elaboration of a component instantiation statement that instanciates + -- a component declaration has no effect unless the component instance + -- is either fully bound to a design entity defined by an entity + -- declaration and architecture body or is bound to a configuration of + -- such a design entity. + if not Is_Fully_Bound (Conf) then + Warning_Msg (Disp_Node (Stmt) & " not bound"); + return; + end if; + + if Trace_Elaboration then + Ada.Text_IO.Put_Line + (" using " & Disp_Node (Conf) & " from " & Disp_Location (Conf)); + end if; + + -- If a component instance is so bound, then elaboration of the + -- corresponding component instantiation statement consists of the + -- elaboration of the implied block statement representing the + -- component instance and [...] + -- FIXME: extract frame. + + -- and (within that block) the implied block statement representing the + -- design entity to which the component instance is so bound. + Arch := Null_Iir; + Arch_Name := Null_Identifier; + Binding := Get_Binding_Indication (Conf); + Aspect := Get_Entity_Aspect (Binding); + + case Get_Kind (Conf) is + when Iir_Kind_Component_Configuration => + Sub_Conf := Get_Block_Configuration (Conf); + when Iir_Kind_Configuration_Specification => + Sub_Conf := Null_Iir; + when others => + raise Internal_Error; + end case; + + case Get_Kind (Aspect) is + when Iir_Kind_Design_Unit => + raise Internal_Error; + when Iir_Kind_Entity_Aspect_Entity => + Entity := Get_Entity (Aspect); + if Get_Architecture (Aspect) /= Null_Iir then + Arch_Name := Get_Identifier (Get_Architecture (Aspect)); + end if; + when Iir_Kind_Entity_Aspect_Configuration => + if Sub_Conf /= Null_Iir then + raise Internal_Error; + end if; + declare + Conf : constant Iir := Get_Configuration (Aspect); + begin + Entity := Get_Entity (Conf); + Sub_Conf := Get_Block_Configuration (Conf); + Arch := Get_Block_Specification (Sub_Conf); + end; + when others => + Error_Kind ("elaborate_component_declaration0", Aspect); + end case; + + if Arch = Null_Iir then + if Arch_Name = Null_Identifier then + Arch := Libraries.Get_Latest_Architecture (Entity); + if Arch = Null_Iir then + Error_Msg_Elab ("no architecture analysed for " + & Disp_Node (Entity), Stmt); + end if; + Arch_Name := Get_Identifier (Arch); + end if; + Arch_Design := Libraries.Load_Secondary_Unit + (Get_Design_Unit (Entity), Arch_Name, Stmt); + if Arch_Design = Null_Iir then + Error_Msg_Elab ("no architecture `" & Name_Table.Image (Arch_Name) + & "' for " & Disp_Node (Entity), Stmt); + end if; + Arch := Get_Library_Unit (Arch_Design); + end if; + + Generic_Map_Aspect_Chain := Get_Generic_Map_Aspect_Chain (Binding); + Port_Map_Aspect_Chain := Get_Port_Map_Aspect_Chain (Binding); + + if Generic_Map_Aspect_Chain = Null_Iir then + -- LRM93 5.2.2 + -- The default binding indication includes a default generic map + -- aspect if the design entity implied by the entity aspect contains + -- formal generic + -- GHDL: this condition is checked by create_default_association. + Generic_Map_Aspect_Chain := + Create_Default_Association (Get_Generic_Chain (Entity), + Get_Generic_Chain (Component), + Stmt); + end if; + + if Port_Map_Aspect_Chain = Null_Iir then + Port_Map_Aspect_Chain := + Create_Default_Association (Get_Port_Chain (Entity), + Get_Port_Chain (Component), + Stmt); + end if; + + if Sub_Conf = Null_Iir then + Sub_Conf := Get_Default_Configuration_Declaration (Arch); + Sub_Conf := Get_Block_Configuration (Get_Library_Unit (Sub_Conf)); + end if; + + -- FIXME: Use Sub_Conf instead of Arch for Stmt ? (But need to add + -- info for block configuration). + Arch_Frame := Elaborate_Architecture + (Arch, Sub_Conf, Comp_Instance, Arch, + Generic_Map_Aspect_Chain, Port_Map_Aspect_Chain); + end Elaborate_Component_Configuration; + + procedure Elaborate_Block_Configuration + (Conf : Iir_Block_Configuration; Instance : Block_Instance_Acc); + + procedure Apply_Block_Configuration_To_Iterative_Generate + (Stmt : Iir; Conf_Chain : Iir; Instance : Block_Instance_Acc) + is + Scheme : constant Iir := Get_Generation_Scheme (Stmt); + Bounds : constant Iir_Value_Literal_Acc := + Execute_Bounds (Instance, Get_Type (Scheme)); + + Sub_Instances : Block_Instance_Acc_Array + (0 .. Instance_Slot_Type (Bounds.Length - 1)); + + type Sub_Conf_Type is array (0 .. Instance_Slot_Type (Bounds.Length - 1)) + of Boolean; + Sub_Conf : Sub_Conf_Type := (others => False); + + Child : Block_Instance_Acc; + + Item : Iir; + Prev_Item : Iir; + Default_Item : Iir := Null_Iir; + Spec : Iir; + Expr : Iir_Value_Literal_Acc; + Ind : Instance_Slot_Type; + begin + -- Gather children + Child := Instance.Children; + for I in reverse Sub_Instances'Range loop + Sub_Instances (I) := Child; + Child := Child.Brother; + end loop; + if Child /= null then + raise Internal_Error; + end if; + + -- Apply configuration items + Item := Conf_Chain; + while Item /= Null_Iir loop + Spec := Get_Block_Specification (Item); + if Get_Kind (Spec) = Iir_Kind_Simple_Name then + Spec := Get_Named_Entity (Spec); + end if; + Prev_Item := Get_Prev_Block_Configuration (Item); + + case Get_Kind (Spec) is + when Iir_Kind_Slice_Name => + Expr := Execute_Bounds (Instance, Get_Suffix (Spec)); + Ind := Instance_Slot_Type + (Get_Index_Offset (Execute_Low_Limit (Expr), Bounds, Spec)); + for I in 1 .. Instance_Slot_Type (Expr.Length) loop + Sub_Conf (Ind + I - 1) := True; + Elaborate_Block_Configuration + (Item, Sub_Instances (Ind + I - 1)); + end loop; + when Iir_Kind_Indexed_Name => + if Get_Index_List (Spec) = Iir_List_Others then + -- Must be the only default block configuration + pragma Assert (Default_Item = Null_Iir); + Default_Item := Item; + else + Expr := Execute_Expression + (Instance, Get_First_Element (Get_Index_List (Spec))); + Ind := Instance_Slot_Type + (Get_Index_Offset (Expr, Bounds, Spec)); + Sub_Conf (Ind) := True; + Elaborate_Block_Configuration (Item, Sub_Instances (Ind)); + end if; + when Iir_Kind_Generate_Statement => + -- Must be the only block configuration + pragma Assert (Item = Conf_Chain); + pragma Assert (Prev_Item = Null_Iir); + for I in Sub_Instances'Range loop + Sub_Conf (I) := True; + Elaborate_Block_Configuration (Item, Sub_Instances (I)); + end loop; + when others => + raise Internal_Error; + end case; + Item := Prev_Item; + end loop; + + if Default_Item /= Null_Iir then + for I in Sub_Instances'Range loop + if not Sub_Conf (I) then + Elaborate_Block_Configuration + (Default_Item, Sub_Instances (I)); + end if; + end loop; + end if; + end Apply_Block_Configuration_To_Iterative_Generate; + + procedure Elaborate_Block_Configuration + (Conf : Iir_Block_Configuration; Instance : Block_Instance_Acc) + is + Blk_Info : constant Sim_Info_Acc := Get_Info (Instance.Stmt); + Sub_Instances : Block_Instance_Acc_Array + (0 .. Blk_Info.Nbr_Instances - 1); + type Iir_Array is array (Instance_Slot_Type range <>) of Iir; + Sub_Conf : Iir_Array (0 .. Blk_Info.Nbr_Instances - 1) := + (others => Null_Iir); + + Item : Iir; + begin + pragma Assert (Conf /= Null_Iir); + + -- Associate configuration items with subinstance. Gather items for + -- for-generate statements. + Item := Get_Configuration_Item_Chain (Conf); + while Item /= Null_Iir loop + case Get_Kind (Item) is + when Iir_Kind_Block_Configuration => + declare + Spec : Iir; + Gen : Iir_Generate_Statement; + Info : Sim_Info_Acc; + begin + Spec := Get_Block_Specification (Item); + if Get_Kind (Spec) = Iir_Kind_Simple_Name then + Spec := Get_Named_Entity (Spec); + end if; + case Get_Kind (Spec) is + when Iir_Kind_Slice_Name + | Iir_Kind_Indexed_Name + | Iir_Kind_Selected_Name => + -- Block configuration for a generate statement. + Gen := Get_Named_Entity (Get_Prefix (Spec)); + Info := Get_Info (Gen); + Set_Prev_Block_Configuration + (Item, Sub_Conf (Info.Inst_Slot)); + Sub_Conf (Info.Inst_Slot) := Item; + when Iir_Kind_Generate_Statement => + Info := Get_Info (Spec); + if Sub_Conf (Info.Inst_Slot) /= Null_Iir then + raise Internal_Error; + end if; + Sub_Conf (Info.Inst_Slot) := Item; + when Iir_Kind_Block_Statement => + -- Block configuration for a block statement. + Info := Get_Info (Spec); + if Sub_Conf (Info.Inst_Slot) /= Null_Iir then + raise Internal_Error; + end if; + Sub_Conf (Info.Inst_Slot) := Item; + when others => + Error_Kind ("elaborate_block_configuration1", Spec); + end case; + end; + + when Iir_Kind_Component_Configuration => + declare + List : constant Iir_List := + Get_Instantiation_List (Item); + El : Iir; + Info : Sim_Info_Acc; + begin + if List = Iir_List_All or else List = Iir_List_Others then + raise Internal_Error; + end if; + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Info := Get_Info (Get_Named_Entity (El)); + if Sub_Conf (Info.Inst_Slot) /= Null_Iir then + raise Internal_Error; + end if; + Sub_Conf (Info.Inst_Slot) := Item; + end loop; + end; + + when others => + Error_Kind ("elaborate_block_configuration", Item); + end case; + Item := Get_Chain (Item); + end loop; + + -- Gather children. + declare + Child : Block_Instance_Acc; + begin + Child := Instance.Children; + while Child /= null loop + declare + Slot : constant Instance_Slot_Type := + Get_Info (Child.Label).Inst_Slot; + begin + if Slot /= Invalid_Instance_Slot then + -- Processes have no slot. + if Sub_Instances (Slot) /= null then + raise Internal_Error; + end if; + Sub_Instances (Slot) := Child; + end if; + end; + Child := Child.Brother; + end loop; + end; + + -- Configure sub instances. + declare + Stmt : Iir; + Info : Sim_Info_Acc; + Slot : Instance_Slot_Type; + begin + Stmt := Get_Concurrent_Statement_Chain (Instance.Stmt); + while Stmt /= Null_Iir loop + case Get_Kind (Stmt) is + when Iir_Kind_Generate_Statement => + Info := Get_Info (Stmt); + Slot := Info.Inst_Slot; + if Get_Kind (Get_Generation_Scheme (Stmt)) + = Iir_Kind_Iterator_Declaration + then + -- Iterative generate: apply to all instances + Apply_Block_Configuration_To_Iterative_Generate + (Stmt, Sub_Conf (Slot), Sub_Instances (Slot)); + else + -- Conditional generate: may not be instantiated + if Sub_Instances (Slot) /= null then + Elaborate_Block_Configuration + (Sub_Conf (Slot), Sub_Instances (Slot)); + end if; + end if; + when Iir_Kind_Block_Statement => + Info := Get_Info (Stmt); + Slot := Info.Inst_Slot; + Elaborate_Block_Configuration + (Sub_Conf (Slot), Sub_Instances (Slot)); + when Iir_Kind_Component_Instantiation_Statement => + if Is_Component_Instantiation (Stmt) then + Info := Get_Info (Stmt); + Slot := Info.Inst_Slot; + Elaborate_Component_Configuration + (Stmt, Sub_Instances (Slot), Sub_Conf (Slot)); + else + -- Nothing to do for entity instantiation, will be + -- done during elaboration of statements. + null; + end if; + when others => + null; + end case; + Stmt := Get_Chain (Stmt); + end loop; + end; + end Elaborate_Block_Configuration; + + procedure Elaborate_Alias_Declaration + (Instance : Block_Instance_Acc; Decl : Iir_Object_Alias_Declaration) + is + Alias_Type : Iir; + Res : Iir_Value_Literal_Acc; + begin + -- LRM93 12.3.1.5 + -- Elaboration of an alias declaration consists of the elaboration + -- of the subtype indication to establish the subtype associated + -- with the alias, folloed by the creation of the alias as an + -- alternative name for the named entity. + -- The creation of an alias for an array object involves a check + -- that the subtype associated with the alias includes a matching + -- element for each element of the named object. + -- It is an error if this check fails. + Alias_Type := Get_Type (Decl); + Elaborate_Subtype_Indication_If_Anonymous (Instance, Alias_Type); + Create_Object (Instance, Decl); + Res := Execute_Name (Instance, Get_Name (Decl), True); + Implicit_Array_Conversion (Instance, Res, Alias_Type, Get_Name (Decl)); + Instance.Objects (Get_Info (Decl).Slot) := + Unshare_Bounds (Res, Instance_Pool); + end Elaborate_Alias_Declaration; + + -- LRM93 §12.3.2.3 Disconnection Specifications + procedure Elaborate_Disconnection_Specification + (Instance : Block_Instance_Acc; + Decl : Iir_Disconnection_Specification) + is + Time_Val : Iir_Value_Literal_Acc; + Time : Iir_Value_Time; + List : Iir_List; + Sig : Iir; + Val : Iir_Value_Literal_Acc; + begin + -- LRM93 §12.3.2.3 + -- Elaboration of a disconnection specification proceeds as follows: + -- 2. The time expression is evaluated to determine the disconnection + -- time for drivers of the affected signals. + Time_Val := Execute_Expression (Instance, Get_Expression (Decl)); + Time := Time_Val.I64; + + -- LRM93 5.3 + -- The time expression in a disconnection specification must be static + -- and must evaluate to a non-negative value. + + if Time < 0 then + Error_Msg_Sem ("time must be non-negative", Decl); + end if; + + -- LRM93 §12.3.2.3 + -- 1. The guarded signal specification is elaborated in order to + -- identify the signals affected by the disconnection specification. + -- + -- 3. The diconnection time is associated with each affected signal for + -- later use in constructing disconnection statements in the + -- equivalent processes for guarded assignments to the affected + -- signals. + List := Get_Signal_List (Decl); + case List is + when Iir_List_All + | Iir_List_Others => + Error_Kind ("elaborate_disconnection_specification", Decl); + when others => + for I in Natural loop + Sig := Get_Nth_Element (List, I); + exit when Sig = Null_Iir; + Val := Execute_Name (Instance, Sig, True); + Disconnection_Table.Append ((Sig => Val, Time => Time)); + end loop; + end case; + end Elaborate_Disconnection_Specification; + + procedure Elaborate_Branch_Quantity_Declaration + (Instance : Block_Instance_Acc; Decl : Iir) + is + Terminal_Plus, Terminal_Minus : Iir; + Plus, Minus : Iir_Value_Literal_Acc; + Res : Iir_Value_Literal_Acc; + begin + Res := Create_Quantity (Instance, Decl); + + Terminal_Plus := Get_Plus_Terminal (Decl); + Plus := Execute_Name (Instance, Terminal_Plus, True); + Terminal_Minus := Get_Minus_Terminal (Decl); + if Terminal_Minus = Null_Iir then + -- Get the reference of the nature + -- FIXME: select/index + Terminal_Minus := Get_Reference (Get_Nature (Terminal_Plus)); + end if; + Minus := Execute_Name (Instance, Terminal_Minus, True); + + case Iir_Kinds_Branch_Quantity_Declaration (Get_Kind (Decl)) is + when Iir_Kind_Across_Quantity_Declaration => + -- Expr: q - P'ref + M'ref + Add_Characteristic_Expression + (Structural, + Build + (Op_Plus, Res.Quantity, + Build (Op_Minus, + Get_Terminal_Reference (Plus.Terminal), + Build (Op_Plus, + Get_Terminal_Reference (Minus.Terminal))))); + when Iir_Kind_Through_Quantity_Declaration => + -- P'Contrib <- P'Contrib + q + -- M'Contrib <- M'Contrib - q + Append_Characteristic_Expression + (Plus.Terminal, Build (Op_Plus, Res.Quantity)); + Append_Characteristic_Expression + (Minus.Terminal, Build (Op_Minus, Res.Quantity)); + end case; + end Elaborate_Branch_Quantity_Declaration; + + -- LRM93 §12.3.1 Elaboration of a declaration + procedure Elaborate_Declaration (Instance : Block_Instance_Acc; Decl : Iir) + is + Expr_Mark : Mark_Type; + Val : Iir_Value_Literal_Acc; + begin + Mark (Expr_Mark, Expr_Pool); + + -- Elaboration of a declaration has the effect of creating the declared + -- item. For each declaration, the language rules (in particular scope + -- and visibility rules) are such that it is either impossible or + -- illegal to use a given item before the elaboration of its + -- corresponding declaration. + -- Similarly, it is illegal to call a subprogram before its + -- corresponding body is elaborated. + case Get_Kind (Decl) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + if not Is_Second_Subprogram_Specification (Decl) then + Elaborate_Subprogram_Declaration (Instance, Decl); + end if; + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + null; + when Iir_Kind_Anonymous_Type_Declaration => + Elaborate_Type_Definition (Instance, Get_Type_Definition (Decl)); + when Iir_Kind_Type_Declaration => + Elaborate_Type_Declaration (Instance, Decl); + when Iir_Kind_Subtype_Declaration => + Elaborate_Subtype_Indication (Instance, Get_Type (Decl)); + when Iir_Kind_Iterator_Declaration => + Elaborate_Subtype_Indication_If_Anonymous + (Instance, Get_Type (Decl)); + Val := Create_Value_For_Type (Instance, Get_Type (Decl), True); + Create_Object (Instance, Decl); + Instance.Objects (Get_Info (Decl).Slot) := + Unshare (Val, Instance_Pool); + when Iir_Kind_Signal_Declaration => + Elaborate_Subtype_Indication_If_Anonymous + (Instance, Get_Type (Decl)); + Val := Elaborate_Default_Value (Instance, Decl); + Create_Signal (Instance, Decl); + Elaborate_Signal (Instance, Decl, Val); + when Iir_Kind_Variable_Declaration => + Elaborate_Subtype_Indication_If_Anonymous + (Instance, Get_Type (Decl)); + Val := Elaborate_Default_Value (Instance, Decl); + Create_Object (Instance, Decl); + Instance.Objects (Get_Info (Decl).Slot) := + Unshare (Val, Instance_Pool); + when Iir_Kind_Constant_Declaration => + -- Elaboration of an object declaration that declares an object + -- other then a file object proceeds as follows: + -- 1. The subtype indication is first elaborated. + -- This establishes the subtype of the object. + if Get_Deferred_Declaration_Flag (Decl) then + Create_Object (Instance, Decl); + else + Elaborate_Subtype_Indication_If_Anonymous + (Instance, Get_Type (Decl)); + Val := Elaborate_Default_Value (Instance, Decl); + if Get_Deferred_Declaration (Decl) = Null_Iir then + Create_Object (Instance, Decl); + end if; + Instance.Objects (Get_Info (Decl).Slot) := + Unshare (Val, Instance_Pool); + end if; + when Iir_Kind_File_Declaration => + -- LRM93 12.3.1.4 + -- Elaboration of a file object declaration consists of the + -- elaboration of the subtype indication... + null; -- FIXME ?? + -- ...followed by the creation of object. + Create_Object (Instance, Decl); + -- If the file object declaration contains file_open_information, + -- then the implicit call to FILE_OPEN is then executed. + Instance.Objects (Get_Info (Decl).Slot) := Unshare + (File_Operation.Elaborate_File_Declaration (Instance, Decl), + Instance_Pool); + when Iir_Kind_Object_Alias_Declaration => + Elaborate_Alias_Declaration (Instance, Decl); + when Iir_Kind_Component_Declaration => + -- LRM93 12.3.1.7 + -- Elaboration of a component declaration has no effect other + -- than to create a template for instantiating component + -- instances. + null; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + null; + when Iir_Kind_Configuration_Specification => + -- Elaboration of a configuration specification proceeds as + -- follows: + -- 1. The component specification is elaborated in order to + -- determine which component instances are affected by the + -- configuration specification. + -- GHDL: this is done during sem. + + -- 2. The binding indication is elaborated to identify the design + -- entity to which the affected component instances will be + -- bound. + -- GHDL: this is already done during sem, according to rules + -- defined by section 5.3.1.1 + + -- 3. The binding information is associated with each affected + -- component instance label for later use in instantiating + -- those component instances. + -- GHDL: this is done during step 1. + + -- As part of this elaboration process, a check is made that both + -- the entity declaration and the corresponding architecture body + -- implied by the binding indication exist whithin the specified + -- library. + -- It is an error if this check fails. + -- GHDL: this is already done during sem, according to rules + -- defined by section 5.3.1.1 + null; + + when Iir_Kind_Attribute_Declaration => + -- LRM93 12.3.1.6 + -- Elaboration of an attribute declaration has no effect other + -- than to create a template for defining attributes of items. + null; + + when Iir_Kind_Attribute_Specification => + -- LRM93 12.3.2.1 + -- Elaboration of an attribute specification proceeds as follows: + -- 1. The entity specification is elaborated in order to + -- determine which items are affected by the attribute + -- specification. + -- GHDL: done by sem. + + declare + Attr_Decl : constant Iir := + Get_Named_Entity (Get_Attribute_Designator (Decl)); + Attr_Type : constant Iir := Get_Type (Attr_Decl); + Value : Iir_Attribute_Value; + Val : Iir_Value_Literal_Acc; + begin + Value := Get_Attribute_Value_Spec_Chain (Decl); + while Value /= Null_Iir loop + -- 2. The expression is evaluated to determine the value + -- of the attribute. + -- It is an error if the value of the expression does not + -- belong to the subtype of the attribute; if the + -- attribute is of an array type, then an implicit + -- subtype conversion is first performed on the value, + -- unless the attribute's subtype indication denotes an + -- unconstrained array type. + Val := Execute_Expression (Instance, Get_Expression (Decl)); + Check_Constraints (Instance, Val, Attr_Type, Decl); + + -- 3. A new instance of the designated attribute is created + -- and associated with each of the affected items. + -- + -- 4. Each new attribute instance is assigned the value of + -- the expression. + Create_Object (Instance, Value); + Instance.Objects (Get_Info (Value).Slot) := + Unshare (Val, Instance_Pool); + + Value := Get_Spec_Chain (Value); + end loop; + end; + + when Iir_Kind_Disconnection_Specification => + Elaborate_Disconnection_Specification (Instance, Decl); + + when Iir_Kind_Use_Clause => + null; + + when Iir_Kind_Delayed_Attribute => + Elaborate_Delayed_Signal (Instance, Decl); + when Iir_Kind_Stable_Attribute => + Elaborate_Implicit_Signal (Instance, Decl, Implicit_Stable); + when Iir_Kind_Quiet_Attribute => + Elaborate_Implicit_Signal (Instance, Decl, Implicit_Quiet); + when Iir_Kind_Transaction_Attribute => + Elaborate_Implicit_Signal (Instance, Decl, Implicit_Transaction); + + when Iir_Kind_Non_Object_Alias_Declaration => + null; + when Iir_Kind_Group_Template_Declaration + | Iir_Kind_Group_Declaration => + null; + when Iir_Kind_Protected_Type_Body => + null; + + when Iir_Kind_Nature_Declaration => + Elaborate_Nature_Definition (Instance, Get_Nature (Decl)); + Create_Terminal (Instance, Get_Chain (Decl)); + + when Iir_Kind_Terminal_Declaration => + Create_Terminal (Instance, Decl); + + when Iir_Kinds_Branch_Quantity_Declaration => + Elaborate_Branch_Quantity_Declaration (Instance, Decl); + + when others => + Error_Kind ("elaborate_declaration", Decl); + end case; + + Release (Expr_Mark, Expr_Pool); + end Elaborate_Declaration; + + procedure Destroy_Iterator_Declaration + (Instance : Block_Instance_Acc; Decl : Iir) + is + Obj_Type : constant Iir := Get_Type (Decl); + Constraint : Iir; + Cons_Info : Sim_Info_Acc; + begin + if Get_Kind (Decl) /= Iir_Kind_Iterator_Declaration then + raise Internal_Error; + end if; + Destroy_Object (Instance, Decl); + + if Get_Kind (Obj_Type) = Iir_Kind_Range_Array_Attribute + or else not Is_Anonymous_Type_Definition (Obj_Type) + then + return; + end if; + + Constraint := Get_Range_Constraint (Obj_Type); + if Get_Kind (Constraint) /= Iir_Kind_Range_Expression then + return; + end if; + Cons_Info := Get_Info (Constraint); + if Cons_Info.Scope_Level = Instance.Scope_Level + and then Cons_Info.Slot = Instance.Elab_Objects + then + Destroy_Object (Instance, Constraint); + end if; + end Destroy_Iterator_Declaration; + + procedure Finalize_Declarative_Part + (Instance : Block_Instance_Acc; Decl_Chain : Iir) + is + Decl : Iir; + Val : Iir_Value_Literal_Acc; + begin + Decl := Decl_Chain; + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_File_Declaration => + -- LRM93 3.4.1 + -- An implicit call to FILE_CLOSE exists in a subprogram body + -- for every file object declared in the corresponding + -- subprogram declarative part. + -- Each such call associates a unique file object with the + -- formal parameter F and is called whenever the corresponding + -- subprogram completes its execution. + Val := Instance.Objects (Get_Info (Decl).Slot); + if Get_Text_File_Flag (Get_Type (Decl)) then + File_Operation.File_Close_Text (Val, Null_Iir); + File_Operation.File_Destroy_Text (Val); + else + File_Operation.File_Close_Binary (Val, Null_Iir); + File_Operation.File_Destroy_Binary (Val); + end if; + when others => + null; + end case; + Decl := Get_Chain (Decl); + end loop; + end Finalize_Declarative_Part; + + -- LRM93 §12.3 Elaboration of a Declarative Part + procedure Elaborate_Declarative_Part + (Instance : Block_Instance_Acc; Decl_Chain : Iir) + is + Decl : Iir; + begin + -- The elaboration of a declarative part consists of the elaboration + -- of the declarative items, if any, in the order in which they are + -- given in the declarative part. + -- [Exception for 'foreign ] + Decl := Decl_Chain; + while Decl /= Null_Iir loop + -- In certain cases, the elaboration of a declarative item involves + -- the evaluation of expressions that appear within the declarative + -- item. + -- The value of any object denoted by a primary in such an expression + -- must be defined at the time the primary is read. + -- In addition, if a primary in such an expression is a function call + -- then the value of any object denoted or appearing as part of an + -- actual designator in the function call must be defined at the + -- time the expression is evaluated. + -- FIXME: check this. + Elaborate_Declaration (Instance, Decl); + Decl := Get_Chain (Decl); + end loop; + end Elaborate_Declarative_Part; + + function Elaborate_Architecture (Arch : Iir_Architecture_Body; + Conf : Iir_Block_Configuration; + Parent_Instance : Block_Instance_Acc; + Stmt : Iir; + Generic_Map : Iir; + Port_Map : Iir) + return Block_Instance_Acc + is + Entity : constant Iir_Entity_Declaration := Get_Entity (Arch); + Instance : Block_Instance_Acc; + Expr_Mark : Mark_Type; + begin + Mark (Expr_Mark, Expr_Pool); + + if Trace_Elaboration then + Ada.Text_IO.Put ("elaborating "); + Ada.Text_IO.Put (Image_Identifier (Arch)); + Ada.Text_IO.Put (" of "); + Ada.Text_IO.Put_Line (Image_Identifier (Entity)); + end if; + + Instance := Create_Block_Instance (Parent_Instance, Arch, Stmt); + Instance.Up_Block := null; -- Packages_Instance; + + -- LRM93 §12.1 + -- Elaboration of a block statement involves first elaborating each not + -- yet elaborated package containing declarations referenced by the + -- block. + Elaborate_Dependence (Get_Design_Unit (Arch)); + + Elaborate_Generic_Clause (Instance, Get_Generic_Chain (Entity)); + Elaborate_Generic_Map_Aspect (Instance, Parent_Instance, Generic_Map); + Elaborate_Port_Clause (Instance, Get_Port_Chain (Entity)); + Elaborate_Port_Map_Aspect (Instance, Parent_Instance, + Get_Port_Chain (Entity), Port_Map); + + Elaborate_Declarative_Part + (Instance, Get_Declaration_Chain (Entity)); + Elaborate_Declarative_Part (Instance, Get_Declaration_Chain (Arch)); + Elaborate_Statement_Part + (Instance, Get_Concurrent_Statement_Chain (Entity)); + Elaborate_Statement_Part + (Instance, Get_Concurrent_Statement_Chain (Arch)); + + -- Configure the unit. This will create sub units. + Elaborate_Block_Configuration (Conf, Instance); + + Release (Expr_Mark, Expr_Pool); + + return Instance; + end Elaborate_Architecture; + + -- Elaborate a design. + procedure Elaborate_Design (Design: Iir_Design_Unit) + is + Unit : constant Iir := Get_Library_Unit (Design); + Conf_Unit : Iir_Design_Unit; + Conf : Iir_Block_Configuration; + Arch_Unit : Iir_Design_Unit; + Arch : Iir_Architecture_Body; + Entity : Iir_Entity_Declaration; + Generic_Map : Iir; + Port_Map : Iir; + begin + Package_Instances := + new Block_Instance_Acc_Array (1 .. Instance_Slot_Type (Nbr_Packages)); + + -- Use a 'fake' process to execute code during elaboration. + Current_Process := No_Process; + + -- Find architecture and configuration for the top unit + case Get_Kind (Unit) is + when Iir_Kind_Architecture_Body => + Arch := Unit; + Conf_Unit := Get_Default_Configuration_Declaration (Unit); + when Iir_Kind_Configuration_Declaration => + Conf_Unit := Design; + Arch := Get_Block_Specification (Get_Block_Configuration (Unit)); + Elaborate_Dependence (Design); + when others => + Error_Kind ("elaborate_design", Unit); + end case; + + Arch_Unit := Get_Design_Unit (Arch); + Entity := Get_Entity (Arch); + + Elaborate_Dependence (Arch_Unit); + + -- Sanity check: memory area for expressions must be empty. + if not Is_Empty (Expr_Pool) then + raise Internal_Error; + end if; + + -- Use default values for top entity generics and ports. + Generic_Map := Create_Default_Association + (Get_Generic_Chain (Entity), Null_Iir, Entity); + Port_Map := Create_Default_Association + (Get_Port_Chain (Entity), Null_Iir, Entity); + + -- Elaborate from the top configuration. + Conf := Get_Block_Configuration (Get_Library_Unit (Conf_Unit)); + Top_Instance := Elaborate_Architecture + (Arch, Conf, null, Arch, Generic_Map, Port_Map); + + Current_Process := null; + + -- Stop now in case of errors. + if Nbr_Errors /= 0 then + Grt.Errors.Fatal_Error; + end if; + + -- Sanity check: memory area for expressions must be empty. + if not Is_Empty (Expr_Pool) then + raise Internal_Error; + end if; + end Elaborate_Design; + +end Elaboration; diff --git a/src/simulate/elaboration.ads b/src/simulate/elaboration.ads new file mode 100644 index 000000000..5a9ea8da2 --- /dev/null +++ b/src/simulate/elaboration.ads @@ -0,0 +1,209 @@ +-- Elaboration for interpretation +-- Copyright (C) 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 GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Ada.Unchecked_Deallocation; +with GNAT.Table; +with Iirs; use Iirs; +with Iir_Values; use Iir_Values; +with Grt.Types; +with Annotations; use Annotations; +with Areapools; + +-- This package elaborates design hierarchy. + +package Elaboration is + Trace_Elaboration : Boolean := False; + Trace_Drivers : Boolean := False; + + -- A block instance with its architecture/entity declaration is an + -- instancied entity. + type Block_Instance_Type; + type Block_Instance_Acc is access Block_Instance_Type; + + type Objects_Array is array (Object_Slot_Type range <>) of + Iir_Value_Literal_Acc; + + -- A block instance with its architecture/entity declaration is an + -- instancied entity. + + type Block_Instance_Type (Max_Objs : Object_Slot_Type) is record + -- Flag for wait statement: true if not yet executed. + In_Wait_Flag : Boolean; + + -- Useful informations for a dynamic block (ie, a frame). + -- The scope level and an access to the block of upper scope level. + Scope_Level: Scope_Level_Type; + Up_Block: Block_Instance_Acc; + + -- Block, architecture, package, process, component instantiation for + -- this instance. + Label : Iir; + + -- For blocks: corresponding block (different from label for direct + -- component instantiation statement and generate iterator). + -- For packages: Null_Iir + -- For subprograms and processes: statement being executed. + Stmt : Iir; + + -- Instanciation tree. + -- Parent is always set (but null for top-level block and packages) + Parent: Block_Instance_Acc; + -- Not null only for blocks and processes. + Children: Block_Instance_Acc; + Brother: Block_Instance_Acc; + + -- Pool marker for the child (only for subprograms and processes). + Marker : Areapools.Mark_Type; + + -- Reference to the actuals, for copy-out when returning from a + -- procedure. + Actuals_Ref : Value_Array_Acc; + + -- Only for function frame; contains the result. + Result: Iir_Value_Literal_Acc; + + -- Last object elaborated (or number of objects elaborated). + -- Note: this is generally the slot index of the next object to be + -- elaborated (this may be wrong for dynamic objects due to execution + -- branches). + Elab_Objects : Object_Slot_Type := 0; + + -- Values of the objects in that frame. + Objects : Objects_Array (1 .. Max_Objs); + end record; + + procedure Free is new Ada.Unchecked_Deallocation + (Object => Block_Instance_Type, Name => Block_Instance_Acc); + + procedure Elaborate_Design (Design: Iir_Design_Unit); + + procedure Elaborate_Declarative_Part + (Instance : Block_Instance_Acc; Decl_Chain : Iir); + + -- Reverse operation of Elaborate_Declarative_Part. + -- At least, finalize files. + procedure Finalize_Declarative_Part + (Instance : Block_Instance_Acc; Decl_Chain : Iir); + + procedure Elaborate_Declaration (Instance : Block_Instance_Acc; Decl : Iir); + + procedure Destroy_Iterator_Declaration + (Instance : Block_Instance_Acc; Decl : Iir); + + -- Create a value for type DECL. Initialize it if DEFAULT is true. + function Create_Value_For_Type + (Block: Block_Instance_Acc; Decl: Iir; Default : Boolean) + return Iir_Value_Literal_Acc; + + -- LRM93 §12.3.1.3 Subtype Declarations + -- The elaboration of a subtype indication creates a subtype. + -- Used for allocator. + procedure Elaborate_Subtype_Indication + (Instance : Block_Instance_Acc; Ind : Iir); + + -- Create object DECL. + -- This does nothing except marking DECL as elaborated. + -- Used by simulation to dynamically create subprograms interfaces. + procedure Create_Object (Instance : Block_Instance_Acc; Decl : Iir); + procedure Create_Signal (Instance : Block_Instance_Acc; Decl : Iir); + + Top_Instance: Block_Instance_Acc; + + type Block_Instance_Acc_Array is array (Instance_Slot_Type range <>) of + Block_Instance_Acc; + type Block_Instance_Acc_Array_Acc is access Block_Instance_Acc_Array; + + Package_Instances : Block_Instance_Acc_Array_Acc; + + -- Disconnections. For each disconnection specification, the elaborator + -- adds an entry in the table. + type Disconnection_Entry is record + Sig : Iir_Value_Literal_Acc; + Time : Iir_Value_Time; + end record; + + package Disconnection_Table is new GNAT.Table + (Table_Component_Type => Disconnection_Entry, + Table_Index_Type => Integer, + Table_Low_Bound => 0, + Table_Initial => 16, + Table_Increment => 100); + + -- Connections. For each associations (block/component/entry), the + -- elaborator adds an entry in that table. + type Connect_Entry is record + Formal : Iir_Value_Literal_Acc; + Formal_Instance : Block_Instance_Acc; + Actual : Iir_Value_Literal_Acc; + Actual_Instance : Block_Instance_Acc; + Assoc : Iir; + end record; + + package Connect_Table is new GNAT.Table + (Table_Component_Type => Connect_Entry, + Table_Index_Type => Integer, + Table_Low_Bound => 0, + Table_Initial => 32, + Table_Increment => 100); + + -- Signals. + type Signal_Type_Kind is + (User_Signal, + Implicit_Quiet, Implicit_Stable, Implicit_Delayed, + Implicit_Transaction, + Guard_Signal); + + type Signal_Entry (Kind : Signal_Type_Kind := User_Signal) is record + Decl : Iir; + Sig : Iir_Value_Literal_Acc; + Instance : Block_Instance_Acc; + case Kind is + when User_Signal => + Init : Iir_Value_Literal_Acc; + when Implicit_Quiet | Implicit_Stable | Implicit_Delayed + | Implicit_Transaction => + Time : Grt.Types.Ghdl_I64; + Prefix : Iir_Value_Literal_Acc; + when Guard_Signal => + null; + end case; + end record; + + package Signals_Table is new GNAT.Table + (Table_Component_Type => Signal_Entry, + Table_Index_Type => Integer, + Table_Low_Bound => 0, + Table_Initial => 128, + Table_Increment => 100); + + type Process_Index_Type is new Natural; + + package Processes_Table is new GNAT.Table + (Table_Component_Type => Block_Instance_Acc, + Table_Index_Type => Process_Index_Type, + Table_Low_Bound => 1, + Table_Initial => 128, + Table_Increment => 100); + + package Protected_Table is new GNAT.Table + (Table_Component_Type => Block_Instance_Acc, + Table_Index_Type => Protected_Index_Type, + Table_Low_Bound => 1, + Table_Initial => 2, + Table_Increment => 100); +end Elaboration; diff --git a/src/simulate/execution.adb b/src/simulate/execution.adb new file mode 100644 index 000000000..ef4cccc46 --- /dev/null +++ b/src/simulate/execution.adb @@ -0,0 +1,4837 @@ +-- Interpreted simulation +-- Copyright (C) 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 GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Ada.Unchecked_Conversion; +with Ada.Text_IO; use Ada.Text_IO; +with System; +with Grt.Types; use Grt.Types; +with Errorout; use Errorout; +with Std_Package; +with Evaluation; +with Iirs_Utils; use Iirs_Utils; +with Annotations; use Annotations; +with Name_Table; +with File_Operation; +with Debugger; use Debugger; +with Std_Names; +with Str_Table; +with Files_Map; +with Iir_Chains; use Iir_Chains; +with Simulation; use Simulation; +with Grt.Astdio; +with Grt.Stdio; +with Grt.Options; +with Grt.Vstrings; +with Grt_Interface; +with Grt.Values; +with Grt.Errors; +with Grt.Std_Logic_1164; + +package body Execution is + + function Execute_Function_Call + (Block: Block_Instance_Acc; Expr: Iir; Imp : Iir) + return Iir_Value_Literal_Acc; + + procedure Finish_Sequential_Statements + (Proc : Process_State_Acc; Complex_Stmt : Iir); + procedure Init_Sequential_Statements + (Proc : Process_State_Acc; Complex_Stmt : Iir); + procedure Update_Next_Statement (Proc : Process_State_Acc); + + -- Display a message when an assertion has failed. + procedure Execute_Failed_Assertion (Report : String; + Severity : Natural; + Stmt: Iir); + + function Get_Instance_By_Scope_Level + (Instance: Block_Instance_Acc; Scope_Level: Scope_Level_Type) + return Block_Instance_Acc + is + Current: Block_Instance_Acc := Instance; + begin + while Current /= null loop + if Current.Scope_Level = Scope_Level then + return Current; + end if; + Current := Current.Up_Block; + end loop; + -- Global scope (packages) + if Scope_Level < Scope_Level_Global then + return Package_Instances (Instance_Slot_Type (-Scope_Level)); + end if; + if Current_Component /= null + and then Current_Component.Scope_Level = Scope_Level + then + return Current_Component; + end if; + if Scope_Level = Scope_Level_Global then + return null; + end if; + raise Internal_Error; + end Get_Instance_By_Scope_Level; + + function Get_Instance_For_Slot (Instance: Block_Instance_Acc; Decl: Iir) + return Block_Instance_Acc + is + begin + return Get_Instance_By_Scope_Level (Instance, + Get_Info (Decl).Scope_Level); + end Get_Instance_For_Slot; + + function Create_Bounds_From_Length (Block : Block_Instance_Acc; + Atype : Iir; + Len : Iir_Index32) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + Index_Bounds : Iir_Value_Literal_Acc; + begin + Index_Bounds := Execute_Bounds (Block, Atype); + + Res := Create_Range_Value (Left => Index_Bounds.Left, + Right => null, + Dir => Index_Bounds.Dir, + Length => Len); + + if Len = 0 then + -- Special case. + Res.Right := Res.Left; + case Res.Left.Kind is + when Iir_Value_I64 => + case Index_Bounds.Dir is + when Iir_To => + Res.Left := Create_I64_Value (Res.Right.I64 + 1); + when Iir_Downto => + Res.Left := Create_I64_Value (Res.Right.I64 - 1); + end case; + when others => + raise Internal_Error; + end case; + else + case Res.Left.Kind is + when Iir_Value_E32 => + declare + R : Ghdl_E32; + begin + case Index_Bounds.Dir is + when Iir_To => + R := Res.Left.E32 + Ghdl_E32 (Len - 1); + when Iir_Downto => + R := Res.Left.E32 - Ghdl_E32 (Len - 1); + end case; + Res.Right := Create_E32_Value (R); + end; + when Iir_Value_I64 => + declare + R : Ghdl_I64; + begin + case Index_Bounds.Dir is + when Iir_To => + R := Res.Left.I64 + Ghdl_I64 (Len - 1); + when Iir_Downto => + R := Res.Left.I64 - Ghdl_I64 (Len - 1); + end case; + Res.Right := Create_I64_Value (R); + end; + when others => + raise Internal_Error; + end case; + end if; + return Res; + end Create_Bounds_From_Length; + + function Execute_High_Limit (Bounds : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + if Bounds.Dir = Iir_To then + return Bounds.Right; + else + return Bounds.Left; + end if; + end Execute_High_Limit; + + function Execute_Low_Limit (Bounds : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + if Bounds.Dir = Iir_To then + return Bounds.Left; + else + return Bounds.Right; + end if; + end Execute_Low_Limit; + + function Execute_Left_Limit (Bounds : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + return Bounds.Left; + end Execute_Left_Limit; + + function Execute_Right_Limit (Bounds : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + return Bounds.Right; + end Execute_Right_Limit; + + function Execute_Length (Bounds : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + return Create_I64_Value (Ghdl_I64 (Bounds.Length)); + end Execute_Length; + + function Create_Enum_Value (Pos : Natural; Etype : Iir) + return Iir_Value_Literal_Acc + is + Base_Type : constant Iir := Get_Base_Type (Etype); + Mode : constant Iir_Value_Kind := + Get_Info (Base_Type).Scalar_Mode; + begin + case Mode is + when Iir_Value_E32 => + return Create_E32_Value (Ghdl_E32 (Pos)); + when Iir_Value_B1 => + return Create_B1_Value (Ghdl_B1'Val (Pos)); + when others => + raise Internal_Error; + end case; + end Create_Enum_Value; + + function String_To_Iir_Value (Str : String) return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + begin + Res := Create_Array_Value (Str'Length, 1); + Res.Bounds.D (1) := Create_Range_Value + (Create_I64_Value (1), + Create_I64_Value (Str'Length), + Iir_To); + for I in Str'Range loop + Res.Val_Array.V (1 + Iir_Index32 (I - Str'First)) := + Create_E32_Value (Character'Pos (Str (I))); + end loop; + return Res; + end String_To_Iir_Value; + + function Execute_Image_Attribute (Val : Iir_Value_Literal_Acc; + Expr_Type : Iir) + return String + is + begin + case Get_Kind (Expr_Type) is + when Iir_Kind_Floating_Type_Definition + | Iir_Kind_Floating_Subtype_Definition => + declare + Str : String (1 .. 24); + Last : Natural; + begin + Grt.Vstrings.To_String (Str, Last, Val.F64); + return Str (Str'First .. Last); + end; + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Integer_Subtype_Definition => + declare + Str : String (1 .. 21); + First : Natural; + begin + Grt.Vstrings.To_String (Str, First, Val.I64); + return Str (First .. Str'Last); + end; + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + declare + Lits : constant Iir_List := + Get_Enumeration_Literal_List (Expr_Type); + Pos : Natural; + begin + case Val.Kind is + when Iir_Value_B1 => + Pos := Ghdl_B1'Pos (Val.B1); + when Iir_Value_E32 => + Pos := Ghdl_E32'Pos (Val.E32); + when others => + raise Internal_Error; + end case; + return Name_Table.Image + (Get_Identifier (Get_Nth_Element (Lits, Pos))); + end; + when Iir_Kind_Physical_Type_Definition + | Iir_Kind_Physical_Subtype_Definition => + declare + Str : String (1 .. 21); + First : Natural; + Id : constant Name_Id := + Get_Identifier (Get_Primary_Unit (Get_Base_Type (Expr_Type))); + begin + Grt.Vstrings.To_String (Str, First, Val.I64); + return Str (First .. Str'Last) & ' ' & Name_Table.Image (Id); + end; + when others => + Error_Kind ("execute_image_attribute", Expr_Type); + end case; + end Execute_Image_Attribute; + + function Execute_Shift_Operator (Left : Iir_Value_Literal_Acc; + Count : Ghdl_I64; + Expr : Iir) + return Iir_Value_Literal_Acc + is + Func : constant Iir_Predefined_Shift_Functions := + Get_Implicit_Definition (Get_Implementation (Expr)); + Cnt : Iir_Index32; + Len : constant Iir_Index32 := Left.Bounds.D (1).Length; + Dir_Left : Boolean; + P : Iir_Index32; + Res : Iir_Value_Literal_Acc; + E : Iir_Value_Literal_Acc; + begin + -- LRM93 7.2.3 + -- That is, if R is 0 or if L is a null array, the return value is L. + if Count = 0 or else Len = 0 then + return Left; + end if; + + case Func is + when Iir_Predefined_Array_Sll + | Iir_Predefined_Array_Sla + | Iir_Predefined_Array_Rol => + Dir_Left := True; + when Iir_Predefined_Array_Srl + | Iir_Predefined_Array_Sra + | Iir_Predefined_Array_Ror => + Dir_Left := False; + end case; + if Count < 0 then + Cnt := Iir_Index32 (-Count); + Dir_Left := not Dir_Left; + else + Cnt := Iir_Index32 (Count); + end if; + + case Func is + when Iir_Predefined_Array_Sll + | Iir_Predefined_Array_Srl => + E := Create_Enum_Value + (0, Get_Element_Subtype (Get_Base_Type (Get_Type (Expr)))); + when Iir_Predefined_Array_Sla + | Iir_Predefined_Array_Sra => + if Dir_Left then + E := Left.Val_Array.V (Len); + else + E := Left.Val_Array.V (1); + end if; + when Iir_Predefined_Array_Rol + | Iir_Predefined_Array_Ror => + Cnt := Cnt mod Len; + if not Dir_Left then + Cnt := (Len - Cnt) mod Len; + end if; + end case; + + Res := Create_Array_Value (1); + Res.Bounds.D (1) := Left.Bounds.D (1); + Create_Array_Data (Res, Len); + P := 1; + + case Func is + when Iir_Predefined_Array_Sll + | Iir_Predefined_Array_Srl + | Iir_Predefined_Array_Sla + | Iir_Predefined_Array_Sra => + if Dir_Left then + if Cnt < Len then + for I in Cnt .. Len - 1 loop + Res.Val_Array.V (P) := Left.Val_Array.V (I + 1); + P := P + 1; + end loop; + else + Cnt := Len; + end if; + for I in 0 .. Cnt - 1 loop + Res.Val_Array.V (P) := E; + P := P + 1; + end loop; + else + if Cnt > Len then + Cnt := Len; + end if; + for I in 0 .. Cnt - 1 loop + Res.Val_Array.V (P) := E; + P := P + 1; + end loop; + for I in Cnt .. Len - 1 loop + Res.Val_Array.V (P) := Left.Val_Array.V (I - Cnt + 1); + P := P + 1; + end loop; + end if; + when Iir_Predefined_Array_Rol + | Iir_Predefined_Array_Ror => + for I in 1 .. Len loop + Res.Val_Array.V (P) := Left.Val_Array.V (Cnt + 1); + P := P + 1; + Cnt := Cnt + 1; + if Cnt = Len then + Cnt := 0; + end if; + end loop; + end case; + return Res; + end Execute_Shift_Operator; + + Hex_Chars : constant array (Natural range 0 .. 15) of Character := + "0123456789ABCDEF"; + + function Execute_Bit_Vector_To_String (Val : Iir_Value_Literal_Acc; + Log_Base : Natural) + return Iir_Value_Literal_Acc + is + Base : constant Natural := 2 ** Log_Base; + Blen : constant Natural := Natural (Val.Bounds.D (1).Length); + Str : String (1 .. (Blen + Log_Base - 1) / Log_Base); + Pos : Natural; + V : Natural; + N : Natural; + begin + V := 0; + N := 1; + Pos := Str'Last; + for I in reverse Val.Val_Array.V'Range loop + V := V + Ghdl_B1'Pos (Val.Val_Array.V (I).B1) * N; + N := N * 2; + if N = Base or else I = Val.Val_Array.V'First then + Str (Pos) := Hex_Chars (V); + Pos := Pos - 1; + N := 1; + V := 0; + end if; + end loop; + return String_To_Iir_Value (Str); + end Execute_Bit_Vector_To_String; + + procedure Check_Std_Ulogic_Dc + (Loc : Iir; V : Grt.Std_Logic_1164.Std_Ulogic) + is + use Grt.Std_Logic_1164; + begin + if V = '-' then + Execute_Failed_Assertion + ("STD_LOGIC_1164: '-' operand for matching ordering operator", + 2, Loc); + end if; + end Check_Std_Ulogic_Dc; + + -- EXPR is the expression whose implementation is an implicit function. + function Execute_Implicit_Function (Block : Block_Instance_Acc; + Expr: Iir; + Left_Param : Iir; + Right_Param : Iir; + Res_Type : Iir) + return Iir_Value_Literal_Acc + is + pragma Unsuppress (Overflow_Check); + + Func : Iir_Predefined_Functions; + + -- Rename definition for monadic operations. + Left, Right: Iir_Value_Literal_Acc; + Operand : Iir_Value_Literal_Acc renames Left; + Result: Iir_Value_Literal_Acc; + + procedure Eval_Right is + begin + Right := Execute_Expression (Block, Right_Param); + end Eval_Right; + + -- Eval right argument, check left and right have same length, + -- Create RESULT from left. + procedure Eval_Array is + begin + Eval_Right; + if Left.Bounds.D (1).Length /= Right.Bounds.D (1).Length then + Error_Msg_Constraint (Expr); + end if; + -- Need to copy as the result is modified. + Result := Unshare (Left, Expr_Pool'Access); + end Eval_Array; + + Imp : Iir; + begin + Imp := Get_Implementation (Expr); + if Get_Kind (Imp) in Iir_Kinds_Denoting_Name then + Imp := Get_Named_Entity (Imp); + end if; + Func := Get_Implicit_Definition (Imp); + + -- Eval left operand. + case Func is + when Iir_Predefined_Now_Function => + Left := null; + when Iir_Predefined_Bit_Rising_Edge + | Iir_Predefined_Boolean_Rising_Edge + | Iir_Predefined_Bit_Falling_Edge + | Iir_Predefined_Boolean_Falling_Edge=> + Operand := Execute_Name (Block, Left_Param, True); + when others => + Left := Execute_Expression (Block, Left_Param); + end case; + Right := null; + + case Func is + when Iir_Predefined_Error => + raise Internal_Error; + + when Iir_Predefined_Array_Array_Concat + | Iir_Predefined_Element_Array_Concat + | Iir_Predefined_Array_Element_Concat + | Iir_Predefined_Element_Element_Concat => + Eval_Right; + + declare + -- Array length of the result. + Len: Iir_Index32; + + -- Index into the result. + Pos: Iir_Index32; + begin + -- Compute the length of the result. + case Func is + when Iir_Predefined_Array_Array_Concat => + Len := Left.Val_Array.Len + Right.Val_Array.Len; + when Iir_Predefined_Element_Array_Concat => + Len := 1 + Right.Val_Array.Len; + when Iir_Predefined_Array_Element_Concat => + Len := Left.Val_Array.Len + 1; + when Iir_Predefined_Element_Element_Concat => + Len := 1 + 1; + when others => + raise Program_Error; + end case; + + -- LRM93 7.2.4 + -- If both operands are null arrays, then the result of the + -- concatenation is the right operand. + if Len = 0 then + -- Note: this return is allowed since LEFT is free, and + -- RIGHT must not be free. + return Right; + end if; + + -- Create the array result. + Result := Create_Array_Value (Len, 1); + Result.Bounds.D (1) := Create_Bounds_From_Length + (Block, Get_First_Element (Get_Index_Subtype_List (Res_Type)), + Len); + + -- Fill the result: left. + case Func is + when Iir_Predefined_Array_Array_Concat + | Iir_Predefined_Array_Element_Concat => + for I in Left.Val_Array.V'Range loop + Result.Val_Array.V (I) := Left.Val_Array.V (I); + end loop; + Pos := Left.Val_Array.Len; + when Iir_Predefined_Element_Array_Concat + | Iir_Predefined_Element_Element_Concat => + Result.Val_Array.V (1) := Left; + Pos := 1; + when others => + raise Program_Error; + end case; + + -- Note: here POS is equal to the position of the last element + -- filled, or 0 if no elements were filled. + + -- Fill the result: right. + case Func is + when Iir_Predefined_Array_Array_Concat + | Iir_Predefined_Element_Array_Concat => + for I in Right.Val_Array.V'Range loop + Result.Val_Array.V (Pos + I) := Right.Val_Array.V (I); + end loop; + when Iir_Predefined_Array_Element_Concat + | Iir_Predefined_Element_Element_Concat => + Result.Val_Array.V (Pos + 1) := Right; + when others => + raise Program_Error; + end case; + end; + + when Iir_Predefined_Bit_And + | Iir_Predefined_Boolean_And => + if Left.B1 = Lit_Enum_0.B1 then + -- Short circuit operator. + Result := Lit_Enum_0; + else + Eval_Right; + Result := Boolean_To_Lit (Right.B1 = Lit_Enum_1.B1); + end if; + when Iir_Predefined_Bit_Nand + | Iir_Predefined_Boolean_Nand => + if Left.B1 = Lit_Enum_0.B1 then + -- Short circuit operator. + Result := Lit_Enum_1; + else + Eval_Right; + Result := Boolean_To_Lit (Right.B1 = Lit_Enum_0.B1); + end if; + when Iir_Predefined_Bit_Or + | Iir_Predefined_Boolean_Or => + if Left.B1 = Lit_Enum_1.B1 then + -- Short circuit operator. + Result := Lit_Enum_1; + else + Eval_Right; + Result := Boolean_To_Lit (Right.B1 = Lit_Enum_1.B1); + end if; + when Iir_Predefined_Bit_Nor + | Iir_Predefined_Boolean_Nor => + if Left.B1 = Lit_Enum_1.B1 then + -- Short circuit operator. + Result := Lit_Enum_0; + else + Eval_Right; + Result := Boolean_To_Lit (Right.B1 = Lit_Enum_0.B1); + end if; + when Iir_Predefined_Bit_Xor + | Iir_Predefined_Boolean_Xor => + Eval_Right; + Result := Boolean_To_Lit (Left.B1 /= Right.B1); + when Iir_Predefined_Bit_Xnor + | Iir_Predefined_Boolean_Xnor => + Eval_Right; + Result := Boolean_To_Lit (Left.B1 = Right.B1); + when Iir_Predefined_Bit_Not + | Iir_Predefined_Boolean_Not => + Result := Boolean_To_Lit (Operand.B1 = Lit_Enum_0.B1); + + when Iir_Predefined_Bit_Condition => + Result := Boolean_To_Lit (Operand.B1 = Lit_Enum_1.B1); + + when Iir_Predefined_Array_Sll + | Iir_Predefined_Array_Srl + | Iir_Predefined_Array_Sla + | Iir_Predefined_Array_Sra + | Iir_Predefined_Array_Rol + | Iir_Predefined_Array_Ror => + Eval_Right; + Result := Execute_Shift_Operator (Left, Right.I64, Expr); + + when Iir_Predefined_Enum_Equality + | Iir_Predefined_Integer_Equality + | Iir_Predefined_Array_Equality + | Iir_Predefined_Access_Equality + | Iir_Predefined_Physical_Equality + | Iir_Predefined_Floating_Equality + | Iir_Predefined_Record_Equality + | Iir_Predefined_Bit_Match_Equality + | Iir_Predefined_Bit_Array_Match_Equality => + Eval_Right; + Result := Boolean_To_Lit (Is_Equal (Left, Right)); + when Iir_Predefined_Enum_Inequality + | Iir_Predefined_Integer_Inequality + | Iir_Predefined_Array_Inequality + | Iir_Predefined_Access_Inequality + | Iir_Predefined_Physical_Inequality + | Iir_Predefined_Floating_Inequality + | Iir_Predefined_Record_Inequality + | Iir_Predefined_Bit_Match_Inequality + | Iir_Predefined_Bit_Array_Match_Inequality => + Eval_Right; + Result := Boolean_To_Lit (not Is_Equal (Left, Right)); + when Iir_Predefined_Integer_Less + | Iir_Predefined_Physical_Less => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + Result := Boolean_To_Lit (Left.I64 < Right.I64); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Integer_Greater + | Iir_Predefined_Physical_Greater => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + Result := Boolean_To_Lit (Left.I64 > Right.I64); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Integer_Less_Equal + | Iir_Predefined_Physical_Less_Equal => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + Result := Boolean_To_Lit (Left.I64 <= Right.I64); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Integer_Greater_Equal + | Iir_Predefined_Physical_Greater_Equal => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + Result := Boolean_To_Lit (Left.I64 >= Right.I64); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Enum_Less => + Eval_Right; + case Left.Kind is + when Iir_Value_B1 => + Result := Boolean_To_Lit (Left.B1 < Right.B1); + when Iir_Value_E32 => + Result := Boolean_To_Lit (Left.E32 < Right.E32); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Enum_Greater => + Eval_Right; + case Left.Kind is + when Iir_Value_B1 => + Result := Boolean_To_Lit (Left.B1 > Right.B1); + when Iir_Value_E32 => + Result := Boolean_To_Lit (Left.E32 > Right.E32); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Enum_Less_Equal => + Eval_Right; + case Left.Kind is + when Iir_Value_B1 => + Result := Boolean_To_Lit (Left.B1 <= Right.B1); + when Iir_Value_E32 => + Result := Boolean_To_Lit (Left.E32 <= Right.E32); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Enum_Greater_Equal => + Eval_Right; + case Left.Kind is + when Iir_Value_B1 => + Result := Boolean_To_Lit (Left.B1 >= Right.B1); + when Iir_Value_E32 => + Result := Boolean_To_Lit (Left.E32 >= Right.E32); + when others => + raise Internal_Error; + end case; + + when Iir_Predefined_Enum_Minimum + | Iir_Predefined_Physical_Minimum => + Eval_Right; + if Compare_Value (Left, Right) = Less then + Result := Left; + else + Result := Right; + end if; + when Iir_Predefined_Enum_Maximum + | Iir_Predefined_Physical_Maximum => + Eval_Right; + if Compare_Value (Left, Right) = Less then + Result := Right; + else + Result := Left; + end if; + + when Iir_Predefined_Integer_Plus + | Iir_Predefined_Physical_Plus => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + Result := Create_I64_Value (Left.I64 + Right.I64); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Integer_Minus + | Iir_Predefined_Physical_Minus => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + Result := Create_I64_Value (Left.I64 - Right.I64); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Integer_Mul => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + Result := Create_I64_Value (Left.I64 * Right.I64); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Integer_Mod => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + if Right.I64 = 0 then + Error_Msg_Constraint (Expr); + end if; + Result := Create_I64_Value (Left.I64 mod Right.I64); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Integer_Rem => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + if Right.I64 = 0 then + Error_Msg_Constraint (Expr); + end if; + Result := Create_I64_Value (Left.I64 rem Right.I64); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Integer_Div => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + if Right.I64 = 0 then + Error_Msg_Constraint (Expr); + end if; + Result := Create_I64_Value (Left.I64 / Right.I64); + when others => + raise Internal_Error; + end case; + + when Iir_Predefined_Integer_Absolute + | Iir_Predefined_Physical_Absolute => + case Operand.Kind is + when Iir_Value_I64 => + Result := Create_I64_Value (abs Operand.I64); + when others => + raise Internal_Error; + end case; + + when Iir_Predefined_Integer_Negation + | Iir_Predefined_Physical_Negation => + case Operand.Kind is + when Iir_Value_I64 => + Result := Create_I64_Value (-Operand.I64); + when others => + raise Internal_Error; + end case; + + when Iir_Predefined_Integer_Identity + | Iir_Predefined_Physical_Identity => + case Operand.Kind is + when Iir_Value_I64 => + Result := Create_I64_Value (Operand.I64); + when others => + raise Internal_Error; + end case; + + when Iir_Predefined_Integer_Exp => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + if Right.I64 < 0 then + Error_Msg_Constraint (Expr); + end if; + Result := Create_I64_Value (Left.I64 ** Natural (Right.I64)); + when others => + raise Internal_Error; + end case; + + when Iir_Predefined_Integer_Minimum => + Eval_Right; + Result := Create_I64_Value (Ghdl_I64'Min (Left.I64, Right.I64)); + when Iir_Predefined_Integer_Maximum => + Eval_Right; + Result := Create_I64_Value (Ghdl_I64'Max (Left.I64, Right.I64)); + + when Iir_Predefined_Floating_Mul => + Eval_Right; + Result := Create_F64_Value (Left.F64 * Right.F64); + when Iir_Predefined_Floating_Div => + Eval_Right; + Result := Create_F64_Value (Left.F64 / Right.F64); + when Iir_Predefined_Floating_Minus => + Eval_Right; + Result := Create_F64_Value (Left.F64 - Right.F64); + when Iir_Predefined_Floating_Plus => + Eval_Right; + Result := Create_F64_Value (Left.F64 + Right.F64); + when Iir_Predefined_Floating_Exp => + Eval_Right; + Result := Create_F64_Value (Left.F64 ** Integer (Right.I64)); + when Iir_Predefined_Floating_Identity => + Result := Create_F64_Value (Operand.F64); + when Iir_Predefined_Floating_Negation => + Result := Create_F64_Value (-Operand.F64); + when Iir_Predefined_Floating_Absolute => + Result := Create_F64_Value (abs (Operand.F64)); + when Iir_Predefined_Floating_Less => + Eval_Right; + Result := Boolean_To_Lit (Left.F64 < Right.F64); + when Iir_Predefined_Floating_Less_Equal => + Eval_Right; + Result := Boolean_To_Lit (Left.F64 <= Right.F64); + when Iir_Predefined_Floating_Greater => + Eval_Right; + Result := Boolean_To_Lit (Left.F64 > Right.F64); + when Iir_Predefined_Floating_Greater_Equal => + Eval_Right; + Result := Boolean_To_Lit (Left.F64 >= Right.F64); + + when Iir_Predefined_Floating_Minimum => + Eval_Right; + Result := Create_F64_Value (Ghdl_F64'Min (Left.F64, Right.F64)); + when Iir_Predefined_Floating_Maximum => + Eval_Right; + Result := Create_F64_Value (Ghdl_F64'Max (Left.F64, Right.F64)); + + when Iir_Predefined_Integer_Physical_Mul => + Eval_Right; + Result := Create_I64_Value (Left.I64 * Right.I64); + when Iir_Predefined_Physical_Integer_Mul => + Eval_Right; + Result := Create_I64_Value (Left.I64 * Right.I64); + when Iir_Predefined_Physical_Physical_Div => + Eval_Right; + Result := Create_I64_Value (Left.I64 / Right.I64); + when Iir_Predefined_Physical_Integer_Div => + Eval_Right; + Result := Create_I64_Value (Left.I64 / Right.I64); + when Iir_Predefined_Real_Physical_Mul => + Eval_Right; + Result := Create_I64_Value + (Ghdl_I64 (Left.F64 * Ghdl_F64 (Right.I64))); + when Iir_Predefined_Physical_Real_Mul => + Eval_Right; + Result := Create_I64_Value + (Ghdl_I64 (Ghdl_F64 (Left.I64) * Right.F64)); + when Iir_Predefined_Physical_Real_Div => + Eval_Right; + Result := Create_I64_Value + (Ghdl_I64 (Ghdl_F64 (Left.I64) / Right.F64)); + + when Iir_Predefined_Universal_I_R_Mul => + Eval_Right; + Result := Create_F64_Value (Ghdl_F64 (Left.I64) * Right.F64); + when Iir_Predefined_Universal_R_I_Mul => + Eval_Right; + Result := Create_F64_Value (Left.F64 * Ghdl_F64 (Right.I64)); + + when Iir_Predefined_TF_Array_And => + Eval_Array; + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + Result.Val_Array.V (I).B1 and Right.Val_Array.V (I).B1; + end loop; + when Iir_Predefined_TF_Array_Nand => + Eval_Array; + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + not (Result.Val_Array.V (I).B1 and Right.Val_Array.V (I).B1); + end loop; + when Iir_Predefined_TF_Array_Or => + Eval_Array; + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + Result.Val_Array.V (I).B1 or Right.Val_Array.V (I).B1; + end loop; + when Iir_Predefined_TF_Array_Nor => + Eval_Array; + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + not (Result.Val_Array.V (I).B1 or Right.Val_Array.V (I).B1); + end loop; + when Iir_Predefined_TF_Array_Xor => + Eval_Array; + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + Result.Val_Array.V (I).B1 xor Right.Val_Array.V (I).B1; + end loop; + when Iir_Predefined_TF_Array_Xnor => + Eval_Array; + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + not (Result.Val_Array.V (I).B1 xor Right.Val_Array.V (I).B1); + end loop; + + when Iir_Predefined_TF_Array_Element_And => + Eval_Right; + Result := Unshare (Left, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + Result.Val_Array.V (I).B1 and Right.B1; + end loop; + when Iir_Predefined_TF_Element_Array_And => + Eval_Right; + Result := Unshare (Right, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + Result.Val_Array.V (I).B1 and Left.B1; + end loop; + + when Iir_Predefined_TF_Array_Element_Or => + Eval_Right; + Result := Unshare (Left, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + Result.Val_Array.V (I).B1 or Right.B1; + end loop; + when Iir_Predefined_TF_Element_Array_Or => + Eval_Right; + Result := Unshare (Right, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + Result.Val_Array.V (I).B1 or Left.B1; + end loop; + + when Iir_Predefined_TF_Array_Element_Xor => + Eval_Right; + Result := Unshare (Left, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + Result.Val_Array.V (I).B1 xor Right.B1; + end loop; + when Iir_Predefined_TF_Element_Array_Xor => + Eval_Right; + Result := Unshare (Right, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + Result.Val_Array.V (I).B1 xor Left.B1; + end loop; + + when Iir_Predefined_TF_Array_Element_Nand => + Eval_Right; + Result := Unshare (Left, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + not (Result.Val_Array.V (I).B1 and Right.B1); + end loop; + when Iir_Predefined_TF_Element_Array_Nand => + Eval_Right; + Result := Unshare (Right, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + not (Result.Val_Array.V (I).B1 and Left.B1); + end loop; + + when Iir_Predefined_TF_Array_Element_Nor => + Eval_Right; + Result := Unshare (Left, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + not (Result.Val_Array.V (I).B1 or Right.B1); + end loop; + when Iir_Predefined_TF_Element_Array_Nor => + Eval_Right; + Result := Unshare (Right, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + not (Result.Val_Array.V (I).B1 or Left.B1); + end loop; + + when Iir_Predefined_TF_Array_Element_Xnor => + Eval_Right; + Result := Unshare (Left, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + not (Result.Val_Array.V (I).B1 xor Right.B1); + end loop; + when Iir_Predefined_TF_Element_Array_Xnor => + Eval_Right; + Result := Unshare (Right, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + not (Result.Val_Array.V (I).B1 xor Left.B1); + end loop; + + when Iir_Predefined_TF_Array_Not => + -- Need to copy as the result is modified. + Result := Unshare (Operand, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := not Result.Val_Array.V (I).B1; + end loop; + + when Iir_Predefined_TF_Reduction_And => + Result := Create_B1_Value (True); + for I in Operand.Val_Array.V'Range loop + Result.B1 := Result.B1 and Operand.Val_Array.V (I).B1; + end loop; + when Iir_Predefined_TF_Reduction_Nand => + Result := Create_B1_Value (True); + for I in Operand.Val_Array.V'Range loop + Result.B1 := Result.B1 and Operand.Val_Array.V (I).B1; + end loop; + Result.B1 := not Result.B1; + when Iir_Predefined_TF_Reduction_Or => + Result := Create_B1_Value (False); + for I in Operand.Val_Array.V'Range loop + Result.B1 := Result.B1 or Operand.Val_Array.V (I).B1; + end loop; + when Iir_Predefined_TF_Reduction_Nor => + Result := Create_B1_Value (False); + for I in Operand.Val_Array.V'Range loop + Result.B1 := Result.B1 or Operand.Val_Array.V (I).B1; + end loop; + Result.B1 := not Result.B1; + when Iir_Predefined_TF_Reduction_Xor => + Result := Create_B1_Value (False); + for I in Operand.Val_Array.V'Range loop + Result.B1 := Result.B1 xor Operand.Val_Array.V (I).B1; + end loop; + when Iir_Predefined_TF_Reduction_Xnor => + Result := Create_B1_Value (False); + for I in Operand.Val_Array.V'Range loop + Result.B1 := Result.B1 xor Operand.Val_Array.V (I).B1; + end loop; + Result.B1 := not Result.B1; + + when Iir_Predefined_Bit_Rising_Edge + | Iir_Predefined_Boolean_Rising_Edge => + return Boolean_To_Lit + (Execute_Event_Attribute (Operand) + and then Execute_Signal_Value (Operand).B1 = True); + when Iir_Predefined_Bit_Falling_Edge + | Iir_Predefined_Boolean_Falling_Edge => + return Boolean_To_Lit + (Execute_Event_Attribute (Operand) + and then Execute_Signal_Value (Operand).B1 = False); + + when Iir_Predefined_Array_Greater => + Eval_Right; + Result := Boolean_To_Lit (Compare_Value (Left, Right) = Greater); + + when Iir_Predefined_Array_Greater_Equal => + Eval_Right; + Result := Boolean_To_Lit (Compare_Value (Left, Right) >= Equal); + + when Iir_Predefined_Array_Less => + Eval_Right; + Result := Boolean_To_Lit (Compare_Value (Left, Right) = Less); + + when Iir_Predefined_Array_Less_Equal => + Eval_Right; + Result := Boolean_To_Lit (Compare_Value (Left, Right) <= Equal); + + when Iir_Predefined_Array_Minimum => + Eval_Right; + if Compare_Value (Left, Right) = Less then + Result := Left; + else + Result := Right; + end if; + when Iir_Predefined_Array_Maximum => + Eval_Right; + if Compare_Value (Left, Right) = Less then + Result := Right; + else + Result := Left; + end if; + + when Iir_Predefined_Vector_Maximum => + declare + El_St : constant Iir := + Get_Return_Type (Get_Implementation (Expr)); + V : Iir_Value_Literal_Acc; + begin + Result := Execute_Low_Limit (Execute_Bounds (Block, El_St)); + for I in Left.Val_Array.V'Range loop + V := Left.Val_Array.V (I); + if Compare_Value (V, Result) = Greater then + Result := V; + end if; + end loop; + end; + when Iir_Predefined_Vector_Minimum => + declare + El_St : constant Iir := + Get_Return_Type (Get_Implementation (Expr)); + V : Iir_Value_Literal_Acc; + begin + Result := Execute_High_Limit (Execute_Bounds (Block, El_St)); + for I in Left.Val_Array.V'Range loop + V := Left.Val_Array.V (I); + if Compare_Value (V, Result) = Less then + Result := V; + end if; + end loop; + end; + + when Iir_Predefined_Endfile => + Result := Boolean_To_Lit (File_Operation.Endfile (Left, Null_Iir)); + + when Iir_Predefined_Now_Function => + Result := Create_I64_Value (Ghdl_I64 (Grt.Types.Current_Time)); + + when Iir_Predefined_Integer_To_String + | Iir_Predefined_Floating_To_String + | Iir_Predefined_Physical_To_String => + Result := String_To_Iir_Value + (Execute_Image_Attribute (Left, Get_Type (Left_Param))); + + when Iir_Predefined_Enum_To_String => + declare + use Name_Table; + Base_Type : constant Iir := + Get_Base_Type (Get_Type (Left_Param)); + Lits : constant Iir_List := + Get_Enumeration_Literal_List (Base_Type); + Pos : constant Natural := Get_Enum_Pos (Left); + Id : Name_Id; + begin + if Base_Type = Std_Package.Character_Type_Definition then + Result := String_To_Iir_Value ((1 => Character'Val (Pos))); + else + Id := Get_Identifier (Get_Nth_Element (Lits, Pos)); + if Is_Character (Id) then + Result := String_To_Iir_Value ((1 => Get_Character (Id))); + else + Result := String_To_Iir_Value (Image (Id)); + end if; + end if; + end; + + when Iir_Predefined_Array_Char_To_String => + declare + Str : String (1 .. Natural (Left.Bounds.D (1).Length)); + Lits : constant Iir_List := + Get_Enumeration_Literal_List + (Get_Base_Type + (Get_Element_Subtype (Get_Type (Left_Param)))); + Pos : Natural; + begin + for I in Left.Val_Array.V'Range loop + Pos := Get_Enum_Pos (Left.Val_Array.V (I)); + Str (Positive (I)) := Name_Table.Get_Character + (Get_Identifier (Get_Nth_Element (Lits, Pos))); + end loop; + Result := String_To_Iir_Value (Str); + end; + + when Iir_Predefined_Bit_Vector_To_Hstring => + return Execute_Bit_Vector_To_String (Left, 4); + + when Iir_Predefined_Bit_Vector_To_Ostring => + return Execute_Bit_Vector_To_String (Left, 3); + + when Iir_Predefined_Real_To_String_Digits => + Eval_Right; + declare + Str : Grt.Vstrings.String_Real_Digits; + Last : Natural; + begin + Grt.Vstrings.To_String + (Str, Last, Left.F64, Ghdl_I32 (Right.I64)); + Result := String_To_Iir_Value (Str (1 .. Last)); + end; + when Iir_Predefined_Real_To_String_Format => + Eval_Right; + declare + Format : String (1 .. Natural (Right.Val_Array.Len) + 1); + Str : Grt.Vstrings.String_Real_Format; + Last : Natural; + begin + for I in Right.Val_Array.V'Range loop + Format (Positive (I)) := + Character'Val (Right.Val_Array.V (I).E32); + end loop; + Format (Format'Last) := ASCII.NUL; + Grt.Vstrings.To_String + (Str, Last, Left.F64, To_Ghdl_C_String (Format'Address)); + Result := String_To_Iir_Value (Str (1 .. Last)); + end; + when Iir_Predefined_Time_To_String_Unit => + Eval_Right; + declare + Str : Grt.Vstrings.String_Time_Unit; + First : Natural; + Unit : Iir; + begin + Unit := Get_Unit_Chain (Std_Package.Time_Type_Definition); + while Unit /= Null_Iir loop + exit when Evaluation.Get_Physical_Value (Unit) + = Iir_Int64 (Right.I64); + Unit := Get_Chain (Unit); + end loop; + if Unit = Null_Iir then + Error_Msg_Exec + ("to_string for time called with wrong unit", Expr); + end if; + Grt.Vstrings.To_String (Str, First, Left.I64, Right.I64); + Result := String_To_Iir_Value + (Str (First .. Str'Last) & ' ' + & Name_Table.Image (Get_Identifier (Unit))); + end; + + when Iir_Predefined_Std_Ulogic_Match_Equality => + Eval_Right; + declare + use Grt.Std_Logic_1164; + begin + Result := Create_E32_Value + (Std_Ulogic'Pos + (Match_Eq_Table (Std_Ulogic'Val (Left.E32), + Std_Ulogic'Val (Right.E32)))); + end; + when Iir_Predefined_Std_Ulogic_Match_Inequality => + Eval_Right; + declare + use Grt.Std_Logic_1164; + begin + Result := Create_E32_Value + (Std_Ulogic'Pos + (Not_Table (Match_Eq_Table (Std_Ulogic'Val (Left.E32), + Std_Ulogic'Val (Right.E32))))); + end; + when Iir_Predefined_Std_Ulogic_Match_Ordering_Functions => + Eval_Right; + declare + use Grt.Std_Logic_1164; + L : constant Std_Ulogic := Std_Ulogic'Val (Left.E32); + R : constant Std_Ulogic := Std_Ulogic'Val (Right.E32); + Res : Std_Ulogic; + begin + Check_Std_Ulogic_Dc (Expr, L); + Check_Std_Ulogic_Dc (Expr, R); + case Iir_Predefined_Std_Ulogic_Match_Ordering_Functions (Func) + is + when Iir_Predefined_Std_Ulogic_Match_Less => + Res := Match_Lt_Table (L, R); + when Iir_Predefined_Std_Ulogic_Match_Less_Equal => + Res := Or_Table (Match_Lt_Table (L, R), + Match_Eq_Table (L, R)); + when Iir_Predefined_Std_Ulogic_Match_Greater => + Res := Not_Table (Or_Table (Match_Lt_Table (L, R), + Match_Eq_Table (L, R))); + when Iir_Predefined_Std_Ulogic_Match_Greater_Equal => + Res := Not_Table (Match_Lt_Table (L, R)); + end case; + Result := Create_E32_Value (Std_Ulogic'Pos (Res)); + end; + + when Iir_Predefined_Std_Ulogic_Array_Match_Equality + | Iir_Predefined_Std_Ulogic_Array_Match_Inequality => + Eval_Right; + if Left.Bounds.D (1).Length /= Right.Bounds.D (1).Length then + Error_Msg_Constraint (Expr); + end if; + declare + use Grt.Std_Logic_1164; + Res : Std_Ulogic := '1'; + begin + Result := Create_E32_Value (Std_Ulogic'Pos ('1')); + for I in Left.Val_Array.V'Range loop + Res := And_Table + (Res, + Match_Eq_Table + (Std_Ulogic'Val (Left.Val_Array.V (I).E32), + Std_Ulogic'Val (Right.Val_Array.V (I).E32))); + end loop; + if Func = Iir_Predefined_Std_Ulogic_Array_Match_Inequality then + Res := Not_Table (Res); + end if; + Result := Create_E32_Value (Std_Ulogic'Pos (Res)); + end; + + when others => + Error_Msg ("execute_implicit_function: unimplemented " & + Iir_Predefined_Functions'Image (Func)); + raise Internal_Error; + end case; + return Result; + exception + when Constraint_Error => + Error_Msg_Constraint (Expr); + end Execute_Implicit_Function; + + procedure Execute_Implicit_Procedure + (Block: Block_Instance_Acc; Stmt: Iir_Procedure_Call) + is + Imp : constant Iir_Implicit_Procedure_Declaration := + Get_Named_Entity (Get_Implementation (Stmt)); + Assoc_Chain : constant Iir := Get_Parameter_Association_Chain (Stmt); + Assoc: Iir; + Args: Iir_Value_Literal_Array (0 .. 3); + Inter_Chain : Iir; + Expr_Mark : Mark_Type; + begin + Mark (Expr_Mark, Expr_Pool); + Assoc := Assoc_Chain; + for I in Iir_Index32 loop + exit when Assoc = Null_Iir; + Args (I) := Execute_Expression (Block, Get_Actual (Assoc)); + Assoc := Get_Chain (Assoc); + end loop; + Inter_Chain := Get_Interface_Declaration_Chain (Imp); + case Get_Implicit_Definition (Imp) is + when Iir_Predefined_Deallocate => + if Args (0).Val_Access /= null then + Free_Heap_Value (Args (0)); + Args (0).Val_Access := null; + end if; + when Iir_Predefined_File_Open => + File_Operation.File_Open + (Args (0), Args (1), Args (2), Inter_Chain, Stmt); + when Iir_Predefined_File_Open_Status => + File_Operation.File_Open_Status + (Args (0), Args (1), Args (2), Args (3), + Get_Chain (Inter_Chain), Stmt); + when Iir_Predefined_Write => + if Get_Text_File_Flag (Get_Type (Inter_Chain)) then + File_Operation.Write_Text (Args (0), Args (1)); + else + File_Operation.Write_Binary (Args (0), Args (1)); + end if; + when Iir_Predefined_Read_Length => + if Get_Text_File_Flag (Get_Type (Inter_Chain)) then + File_Operation.Read_Length_Text + (Args (0), Args (1), Args (2)); + else + File_Operation.Read_Length_Binary + (Args (0), Args (1), Args (2)); + end if; + when Iir_Predefined_Read => + File_Operation.Read_Binary (Args (0), Args (1)); + when Iir_Predefined_Flush => + File_Operation.Flush (Args (0)); + when Iir_Predefined_File_Close => + if Get_Text_File_Flag (Get_Type (Inter_Chain)) then + File_Operation.File_Close_Text (Args (0), Stmt); + else + File_Operation.File_Close_Binary (Args (0), Stmt); + end if; + when others => + Error_Kind ("execute_implicit_procedure", + Get_Implicit_Definition (Imp)); + end case; + Release (Expr_Mark, Expr_Pool); + end Execute_Implicit_Procedure; + + procedure Execute_Foreign_Procedure + (Block: Block_Instance_Acc; Stmt: Iir_Procedure_Call) + is + Imp : constant Iir_Implicit_Procedure_Declaration := + Get_Implementation (Stmt); + Assoc_Chain : constant Iir := Get_Parameter_Association_Chain (Stmt); + Assoc: Iir; + Args: Iir_Value_Literal_Array (0 .. 3) := (others => null); + Expr_Mark : Mark_Type; + begin + Mark (Expr_Mark, Expr_Pool); + Assoc := Assoc_Chain; + for I in Args'Range loop + exit when Assoc = Null_Iir; + Args (I) := Execute_Expression (Block, Get_Actual (Assoc)); + Assoc := Get_Chain (Assoc); + end loop; + case Get_Identifier (Imp) is + when Std_Names.Name_Untruncated_Text_Read => + File_Operation.Untruncated_Text_Read + (Args (0), Args (1), Args (2)); + when Std_Names.Name_Control_Simulation => + Put_Line (Standard_Error, "simulation finished"); + raise Simulation_Finished; + when others => + Error_Msg_Exec ("unsupported foreign procedure call", Stmt); + end case; + Release (Expr_Mark, Expr_Pool); + end Execute_Foreign_Procedure; + + -- Compute the offset for INDEX into a range BOUNDS. + -- EXPR is only used in case of error. + function Get_Index_Offset + (Index: Iir_Value_Literal_Acc; + Bounds: Iir_Value_Literal_Acc; + Expr: Iir) + return Iir_Index32 + is + Left_Pos, Right_Pos: Iir_Value_Literal_Acc; + begin + Left_Pos := Bounds.Left; + Right_Pos := Bounds.Right; + if Index.Kind /= Left_Pos.Kind or else Index.Kind /= Right_Pos.Kind then + raise Internal_Error; + end if; + case Index.Kind is + when Iir_Value_B1 => + case Bounds.Dir is + when Iir_To => + if Index.B1 >= Left_Pos.B1 and then + Index.B1 <= Right_Pos.B1 + then + -- to + return Ghdl_B1'Pos (Index.B1) - Ghdl_B1'Pos (Left_Pos.B1); + end if; + when Iir_Downto => + if Index.B1 <= Left_Pos.B1 and then + Index.B1 >= Right_Pos.B1 + then + -- downto + return Ghdl_B1'Pos (Left_Pos.B1) - Ghdl_B1'Pos (Index.B1); + end if; + end case; + when Iir_Value_E32 => + case Bounds.Dir is + when Iir_To => + if Index.E32 >= Left_Pos.E32 and then + Index.E32 <= Right_Pos.E32 + then + -- to + return Iir_Index32 (Index.E32 - Left_Pos.E32); + end if; + when Iir_Downto => + if Index.E32 <= Left_Pos.E32 and then + Index.E32 >= Right_Pos.E32 + then + -- downto + return Iir_Index32 (Left_Pos.E32 - Index.E32); + end if; + end case; + when Iir_Value_I64 => + case Bounds.Dir is + when Iir_To => + if Index.I64 >= Left_Pos.I64 and then + Index.I64 <= Right_Pos.I64 + then + -- to + return Iir_Index32 (Index.I64 - Left_Pos.I64); + end if; + when Iir_Downto => + if Index.I64 <= Left_Pos.I64 and then + Index.I64 >= Right_Pos.I64 + then + -- downto + return Iir_Index32 (Left_Pos.I64 - Index.I64); + end if; + end case; + when others => + raise Internal_Error; + end case; + Error_Msg_Constraint (Expr); + return 0; + end Get_Index_Offset; + + -- Create an iir_value_literal of kind iir_value_array and of life LIFE. + -- Allocate the array of bounds, and fill it from A_TYPE. + -- Allocate the array of values. + function Create_Array_Bounds_From_Type + (Block : Block_Instance_Acc; + A_Type : Iir; + Create_Val_Array : Boolean) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + Index_List : Iir_List; + Len : Iir_Index32; + Bound : Iir_Value_Literal_Acc; + begin + -- Only for constrained subtypes. + if Get_Kind (A_Type) = Iir_Kind_Array_Type_Definition then + raise Internal_Error; + end if; + + Index_List := Get_Index_Subtype_List (A_Type); + Res := Create_Array_Value + (Iir_Index32 (Get_Nbr_Elements (Index_List))); + Len := 1; + for I in 1 .. Res.Bounds.Nbr_Dims loop + Bound := Execute_Bounds + (Block, Get_Nth_Element (Index_List, Natural (I - 1))); + Len := Len * Bound.Length; + Res.Bounds.D (I) := Bound; + end loop; + if Create_Val_Array then + Create_Array_Data (Res, Len); + end if; + return Res; + end Create_Array_Bounds_From_Type; + + -- Return the steps (ie, offset in the array when index DIM is increased + -- by one) for array ARR and dimension DIM. + function Get_Step_For_Dim (Arr: Iir_Value_Literal_Acc; Dim : Natural) + return Iir_Index32 + is + Bounds : Value_Bounds_Array_Acc renames Arr.Bounds; + Res : Iir_Index32; + begin + Res := 1; + for I in Iir_Index32 (Dim + 1) .. Bounds.Nbr_Dims loop + Res := Res * Bounds.D (I).Length; + end loop; + return Res; + end Get_Step_For_Dim; + + -- Create a literal for a string or a bit_string + function String_To_Enumeration_Array_1 (Str: Iir; El_Type : Iir) + return Iir_Value_Literal_Acc + is + Lit: Iir_Value_Literal_Acc; + Element_Mode : Iir_Value_Scalars; + + procedure Create_Lit_El + (Index : Iir_Index32; Literal: Iir_Enumeration_Literal) + is + R : Iir_Value_Literal_Acc; + P : constant Iir_Int32 := Get_Enum_Pos (Literal); + begin + case Element_Mode is + when Iir_Value_B1 => + R := Create_B1_Value (Ghdl_B1'Val (P)); + when Iir_Value_E32 => + R := Create_E32_Value (Ghdl_E32'Val (P)); + when others => + raise Internal_Error; + end case; + Lit.Val_Array.V (Index) := R; + end Create_Lit_El; + + El_Btype : constant Iir := Get_Base_Type (El_Type); + Literal_List: constant Iir_List := + Get_Enumeration_Literal_List (El_Btype); + Len: Iir_Index32; + Str_As_Str: constant String := Iirs_Utils.Image_String_Lit (Str); + El : Iir; + begin + Element_Mode := Get_Info (El_Btype).Scalar_Mode; + + case Get_Kind (Str) is + when Iir_Kind_String_Literal => + Len := Iir_Index32 (Str_As_Str'Length); + Lit := Create_Array_Value (Len, 1); + + for I in Lit.Val_Array.V'Range loop + -- FIXME: use literal from type ?? + El := Find_Name_In_List + (Literal_List, + Name_Table.Get_Identifier (Str_As_Str (Natural (I)))); + if El = Null_Iir then + -- FIXME: could free what was already built. + return null; + end if; + Create_Lit_El (I, El); + end loop; + + when Iir_Kind_Bit_String_Literal => + declare + Lit_0, Lit_1 : Iir; + Buf : String_Fat_Acc; + Len1 : Int32; + begin + Lit_0 := Get_Bit_String_0 (Str); + Lit_1 := Get_Bit_String_1 (Str); + Buf := Str_Table.Get_String_Fat_Acc (Get_String_Id (Str)); + Len1 := Get_String_Length (Str); + Lit := Create_Array_Value (Iir_Index32 (Len1), 1); + + if Lit_0 = Null_Iir or Lit_1 = Null_Iir then + raise Internal_Error; + end if; + for I in 1 .. Len1 loop + case Buf (I) is + when '0' => + Create_Lit_El (Iir_Index32 (I), Lit_0); + when '1' => + Create_Lit_El (Iir_Index32 (I), Lit_1); + when others => + raise Internal_Error; + end case; + end loop; + end; + when others => + raise Internal_Error; + end case; + + return Lit; + end String_To_Enumeration_Array_1; + + -- Create a literal for a string or a bit_string + function String_To_Enumeration_Array (Block: Block_Instance_Acc; Str: Iir) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + Array_Type: constant Iir := Get_Type (Str); + Index_Types : constant Iir_List := Get_Index_Subtype_List (Array_Type); + begin + if Get_Nbr_Elements (Index_Types) /= 1 then + raise Internal_Error; -- array must be unidimensional + end if; + + Res := String_To_Enumeration_Array_1 + (Str, Get_Element_Subtype (Array_Type)); + + -- When created from static evaluation, a string may still have an + -- unconstrained type. + if Get_Constraint_State (Array_Type) /= Fully_Constrained then + Res.Bounds.D (1) := + Create_Range_Value (Create_I64_Value (1), + Create_I64_Value (Ghdl_I64 (Res.Val_Array.Len)), + Iir_To, + Res.Val_Array.Len); + else + Res.Bounds.D (1) := + Execute_Bounds (Block, Get_First_Element (Index_Types)); + end if; + + -- The range may not be statically constant. + if Res.Bounds.D (1).Length /= Res.Val_Array.Len then + Error_Msg_Constraint (Str); + end if; + + return Res; + end String_To_Enumeration_Array; + + -- Fill LENGTH elements of RES, starting at ORIG by steps of STEP. + -- Use expressions from (BLOCK, AGGREGATE) to fill the elements. + -- EL_TYPE is the type of the array element. + procedure Fill_Array_Aggregate_1 + (Block : Block_Instance_Acc; + Aggregate : Iir; + Res : Iir_Value_Literal_Acc; + Orig : Iir_Index32; + Step : Iir_Index32; + Dim : Iir_Index32; + Nbr_Dim : Iir_Index32; + El_Type : Iir) + is + Value : Iir; + Bound : constant Iir_Value_Literal_Acc := Res.Bounds.D (Dim); + + procedure Set_Elem (Pos : Iir_Index32) + is + Val : Iir_Value_Literal_Acc; + begin + if Dim = Nbr_Dim then + -- VALUE is an expression (which may be an aggregate, but not + -- a sub-aggregate. + Val := Execute_Expression_With_Type (Block, Value, El_Type); + -- LRM93 7.3.2.2 + -- For a multi-dimensional aggregate of dimension n, a check + -- is made that all (n-1)-dimensional subaggregates have the + -- same bounds. + -- GHDL: I have added an implicit array conversion, however + -- it may be useful to allow cases like this: + -- type str_array is array (natural range <>) + -- of string (10 downto 1); + -- constant floats : str_array := + -- ( "00000000.0", HT & "+1.5ABCDE"); + -- The subtype of the first sub-aggregate (0.0) is + -- determinated by the context, according to rule 9 and 4 + -- of LRM93 7.3.2.2 and therefore is string (10 downto 1), + -- while the subtype of the second sub-aggregate (HT & ...) + -- is determinated by rules 1 and 2 of LRM 7.2.4, and is + -- string (1 to 10). + -- Unless an implicit conversion is used, according to the + -- LRM, this should fail, but it makes no sens. + -- + -- FIXME: Add a warning, a flag ? + --Implicit_Array_Conversion (Block, Val, El_Type, Value); + --Check_Constraints (Block, Val, El_Type, Value); + Res.Val_Array.V (1 + Orig + Pos * Step) := Val; + else + case Get_Kind (Value) is + when Iir_Kind_Aggregate => + -- VALUE is a sub-aggregate. + Fill_Array_Aggregate_1 (Block, Value, Res, + Orig + Pos * Step, + Step / Res.Bounds.D (Dim + 1).Length, + Dim + 1, Nbr_Dim, El_Type); + when Iir_Kind_String_Literal + | Iir_Kind_Bit_String_Literal => + pragma Assert (Dim + 1 = Nbr_Dim); + Val := String_To_Enumeration_Array_1 (Value, El_Type); + if Val.Val_Array.Len /= Res.Bounds.D (Nbr_Dim).Length then + Error_Msg_Constraint (Value); + end if; + for I in Val.Val_Array.V'Range loop + Res.Val_Array.V (Orig + Pos * Step + I) := + Val.Val_Array.V (I); + end loop; + when others => + Error_Kind ("fill_array_aggregate_1", Value); + end case; + end if; + end Set_Elem; + + procedure Set_Elem_By_Expr (Expr : Iir) + is + Expr_Pos: Iir_Value_Literal_Acc; + begin + Expr_Pos := Execute_Expression (Block, Expr); + Set_Elem (Get_Index_Offset (Expr_Pos, Bound, Expr)); + end Set_Elem_By_Expr; + + procedure Set_Elem_By_Range (Expr : Iir) + is + A_Range : Iir_Value_Literal_Acc; + High, Low : Iir_Value_Literal_Acc; + begin + A_Range := Execute_Bounds (Block, Expr); + if Is_Nul_Range (A_Range) then + return; + end if; + if A_Range.Dir = Iir_To then + High := A_Range.Right; + Low := A_Range.Left; + else + High := A_Range.Left; + Low := A_Range.Right; + end if; + + -- Locally modified (incremented) + Low := Unshare (Low, Expr_Pool'Access); + + loop + Set_Elem (Get_Index_Offset (Low, Bound, Expr)); + exit when Is_Equal (Low, High); + Increment (Low); + end loop; + end Set_Elem_By_Range; + + Length : constant Iir_Index32 := Bound.Length; + Assoc : Iir; + Pos : Iir_Index32; + begin + Assoc := Get_Association_Choices_Chain (Aggregate); + Pos := 0; + while Assoc /= Null_Iir loop + Value := Get_Associated_Expr (Assoc); + loop + case Get_Kind (Assoc) is + when Iir_Kind_Choice_By_None => + if Pos >= Length then + Error_Msg_Constraint (Assoc); + end if; + Set_Elem (Pos); + Pos := Pos + 1; + when Iir_Kind_Choice_By_Expression => + Set_Elem_By_Expr (Get_Choice_Expression (Assoc)); + when Iir_Kind_Choice_By_Range => + Set_Elem_By_Range (Get_Choice_Range (Assoc)); + when Iir_Kind_Choice_By_Others => + for J in 1 .. Length loop + if Res.Val_Array.V (Orig + J * Step) = null then + Set_Elem (J - 1); + end if; + end loop; + return; + when others => + raise Internal_Error; + end case; + Assoc := Get_Chain (Assoc); + exit when Assoc = Null_Iir; + exit when not Get_Same_Alternative_Flag (Assoc); + end loop; + end loop; + + -- Check each elements have been set. + -- FIXME: check directly with type. + for J in 1 .. Length loop + if Res.Val_Array.V (Orig + J * Step) = null then + Error_Msg_Constraint (Aggregate); + end if; + end loop; + end Fill_Array_Aggregate_1; + + -- Use expressions from (BLOCK, AGGREGATE) to fill RES. + procedure Fill_Array_Aggregate + (Block : Block_Instance_Acc; + Aggregate : Iir; + Res : Iir_Value_Literal_Acc) + is + Aggr_Type : constant Iir := Get_Type (Aggregate); + El_Type : constant Iir := Get_Element_Subtype (Aggr_Type); + Index_List : constant Iir_List := Get_Index_Subtype_List (Aggr_Type); + Nbr_Dim : constant Iir_Index32 := + Iir_Index32 (Get_Nbr_Elements (Index_List)); + Step : Iir_Index32; + begin + Step := Get_Step_For_Dim (Res, 1); + Fill_Array_Aggregate_1 + (Block, Aggregate, Res, 0, Step, 1, Nbr_Dim, El_Type); + end Fill_Array_Aggregate; + + function Execute_Record_Aggregate (Block: Block_Instance_Acc; + Aggregate: Iir; + Aggregate_Type: Iir) + return Iir_Value_Literal_Acc + is + List : constant Iir_List := + Get_Elements_Declaration_List (Get_Base_Type (Aggregate_Type)); + + Res: Iir_Value_Literal_Acc; + Expr : Iir; + + procedure Set_Expr (Pos : Iir_Index32) is + El : constant Iir := Get_Nth_Element (List, Natural (Pos - 1)); + begin + Res.Val_Record.V (Pos) := + Execute_Expression_With_Type (Block, Expr, Get_Type (El)); + end Set_Expr; + + Pos : Iir_Index32; + Assoc: Iir; + N_Expr : Iir; + begin + Res := Create_Record_Value (Iir_Index32 (Get_Nbr_Elements (List))); + + Assoc := Get_Association_Choices_Chain (Aggregate); + Pos := 1; + loop + N_Expr := Get_Associated_Expr (Assoc); + if N_Expr /= Null_Iir then + Expr := N_Expr; + end if; + case Get_Kind (Assoc) is + when Iir_Kind_Choice_By_None => + Set_Expr (Pos); + Pos := Pos + 1; + when Iir_Kind_Choice_By_Name => + Set_Expr (1 + Get_Element_Position (Get_Choice_Name (Assoc))); + when Iir_Kind_Choice_By_Others => + for I in Res.Val_Record.V'Range loop + if Res.Val_Record.V (I) = null then + Set_Expr (I); + end if; + end loop; + when others => + Error_Kind ("execute_record_aggregate", Assoc); + end case; + Assoc := Get_Chain (Assoc); + exit when Assoc = Null_Iir; + end loop; + return Res; + end Execute_Record_Aggregate; + + function Execute_Aggregate + (Block: Block_Instance_Acc; + Aggregate: Iir; + Aggregate_Type: Iir) + return Iir_Value_Literal_Acc + is + begin + case Get_Kind (Aggregate_Type) is + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + declare + Res : Iir_Value_Literal_Acc; + begin + Res := Create_Array_Bounds_From_Type + (Block, Aggregate_Type, True); + Fill_Array_Aggregate (Block, Aggregate, Res); + return Res; + end; + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + return Execute_Record_Aggregate + (Block, Aggregate, Aggregate_Type); + when others => + Error_Kind ("execute_aggregate", Aggregate_Type); + end case; + end Execute_Aggregate; + + function Execute_Simple_Aggregate (Block: Block_Instance_Acc; Aggr : Iir) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + List : constant Iir_List := Get_Simple_Aggregate_List (Aggr); + begin + Res := Create_Array_Bounds_From_Type (Block, Get_Type (Aggr), True); + for I in Res.Val_Array.V'Range loop + Res.Val_Array.V (I) := + Execute_Expression (Block, Get_Nth_Element (List, Natural (I - 1))); + end loop; + return Res; + end Execute_Simple_Aggregate; + + -- Fill LENGTH elements of RES, starting at ORIG by steps of STEP. + -- Use expressions from (BLOCK, AGGREGATE) to fill the elements. + -- EL_TYPE is the type of the array element. + procedure Execute_Name_Array_Aggregate + (Block : Block_Instance_Acc; + Aggregate : Iir; + Res : Iir_Value_Literal_Acc; + Orig : Iir_Index32; + Step : Iir_Index32; + Dim : Iir_Index32; + Nbr_Dim : Iir_Index32; + El_Type : Iir) + is + Value : Iir; + Bound : Iir_Value_Literal_Acc; + + procedure Set_Elem (Pos : Iir_Index32) + is + Val : Iir_Value_Literal_Acc; + Is_Sig : Boolean; + begin + if Dim = Nbr_Dim then + -- VALUE is an expression (which may be an aggregate, but not + -- a sub-aggregate. + Execute_Name_With_Base (Block, Value, null, Val, Is_Sig); + Res.Val_Array.V (1 + Orig + Pos * Step) := Val; + else + -- VALUE is a sub-aggregate. + Execute_Name_Array_Aggregate + (Block, Value, Res, + Orig + Pos * Step, + Step / Res.Bounds.D (Dim + 1).Length, + Dim + 1, Nbr_Dim, El_Type); + end if; + end Set_Elem; + + Assoc : Iir; + Pos : Iir_Index32; + begin + Assoc := Get_Association_Choices_Chain (Aggregate); + Bound := Res.Bounds.D (Dim); + Pos := 0; + while Assoc /= Null_Iir loop + Value := Get_Associated_Expr (Assoc); + case Get_Kind (Assoc) is + when Iir_Kind_Choice_By_None => + null; + when Iir_Kind_Choice_By_Expression => + declare + Expr_Pos: Iir_Value_Literal_Acc; + Val : constant Iir := Get_Expression (Assoc); + begin + Expr_Pos := Execute_Expression (Block, Val); + Pos := Get_Index_Offset (Expr_Pos, Bound, Val); + end; + when others => + raise Internal_Error; + end case; + Set_Elem (Pos); + Pos := Pos + 1; + Assoc := Get_Chain (Assoc); + end loop; + end Execute_Name_Array_Aggregate; + + function Execute_Record_Name_Aggregate + (Block: Block_Instance_Acc; + Aggregate: Iir; + Aggregate_Type: Iir) + return Iir_Value_Literal_Acc + is + List : constant Iir_List := + Get_Elements_Declaration_List (Get_Base_Type (Aggregate_Type)); + Res: Iir_Value_Literal_Acc; + Expr : Iir; + Pos : Iir_Index32; + El_Pos : Iir_Index32; + Is_Sig : Boolean; + Assoc: Iir; + begin + Res := Create_Record_Value (Iir_Index32 (Get_Nbr_Elements (List))); + Assoc := Get_Association_Choices_Chain (Aggregate); + Pos := 0; + loop + Expr := Get_Associated_Expr (Assoc); + if Expr = Null_Iir then + -- List of choices is not allowed. + raise Internal_Error; + end if; + case Get_Kind (Assoc) is + when Iir_Kind_Choice_By_None => + El_Pos := Pos; + Pos := Pos + 1; + when Iir_Kind_Choice_By_Name => + El_Pos := Get_Element_Position (Get_Name (Assoc)); + when Iir_Kind_Choice_By_Others => + raise Internal_Error; + when others => + Error_Kind ("execute_record_name_aggregate", Assoc); + end case; + Execute_Name_With_Base + (Block, Expr, null, Res.Val_Record.V (1 + El_Pos), Is_Sig); + Assoc := Get_Chain (Assoc); + exit when Assoc = Null_Iir; + end loop; + return Res; + end Execute_Record_Name_Aggregate; + + function Execute_Name_Aggregate + (Block: Block_Instance_Acc; + Aggregate: Iir; + Aggregate_Type: Iir) + return Iir_Value_Literal_Acc + is + begin + case Get_Kind (Aggregate_Type) is + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + declare + Res : Iir_Value_Literal_Acc; + El_Type : constant Iir := Get_Element_Subtype (Aggregate_Type); + Index_List : constant Iir_List := + Get_Index_Subtype_List (Aggregate_Type); + Nbr_Dim : constant Iir_Index32 := + Iir_Index32 (Get_Nbr_Elements (Index_List)); + Step : Iir_Index32; + begin + Res := Create_Array_Bounds_From_Type + (Block, Aggregate_Type, True); + Step := Get_Step_For_Dim (Res, 1); + Execute_Name_Array_Aggregate + (Block, Aggregate, Res, 0, Step, 1, Nbr_Dim, El_Type); + return Res; + end; + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + return Execute_Record_Name_Aggregate + (Block, Aggregate, Aggregate_Type); + when others => + Error_Kind ("execute_name_aggregate", Aggregate_Type); + end case; + end Execute_Name_Aggregate; + + -- Return the indexes range of dimension DIM for type or object PREFIX. + -- DIM starts at 1. + function Execute_Indexes + (Block: Block_Instance_Acc; Prefix: Iir; Dim : Iir_Int64) + return Iir_Value_Literal_Acc + is + begin + case Get_Kind (Prefix) is + when Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration => + declare + Index : Iir; + begin + Index := Get_Nth_Element + (Get_Index_Subtype_List (Get_Type (Prefix)), + Natural (Dim - 1)); + return Execute_Bounds (Block, Index); + end; + when Iir_Kinds_Denoting_Name => + return Execute_Indexes (Block, Get_Named_Entity (Prefix), Dim); + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + Error_Kind ("execute_indexes", Prefix); + when others => + declare + Orig : Iir_Value_Literal_Acc; + begin + Orig := Execute_Name (Block, Prefix, True); + return Orig.Bounds.D (Iir_Index32 (Dim)); + end; + end case; + end Execute_Indexes; + + function Execute_Bounds (Block: Block_Instance_Acc; Prefix: Iir) + return Iir_Value_Literal_Acc + is + Bound : Iir_Value_Literal_Acc; + begin + case Get_Kind (Prefix) is + when Iir_Kind_Range_Expression => + declare + Info : constant Sim_Info_Acc := Get_Info (Prefix); + begin + if Info = null then + Bound := Create_Range_Value + (Execute_Expression (Block, Get_Left_Limit (Prefix)), + Execute_Expression (Block, Get_Right_Limit (Prefix)), + Get_Direction (Prefix)); + elsif Info.Kind = Kind_Object then + Bound := Get_Instance_For_Slot + (Block, Prefix).Objects (Info.Slot); + else + raise Internal_Error; + end if; + end; + + when Iir_Kind_Subtype_Declaration => + return Execute_Bounds (Block, Get_Type (Prefix)); + + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Physical_Subtype_Definition => + -- FIXME: move this block before and avoid recursion. + return Execute_Bounds (Block, Get_Range_Constraint (Prefix)); + + when Iir_Kind_Range_Array_Attribute => + declare + Prefix_Val : Iir_Value_Literal_Acc; + Dim : Iir_Int64; + begin + Dim := Get_Value (Get_Parameter (Prefix)); + Prefix_Val := Execute_Indexes (Block, Get_Prefix (Prefix), Dim); + Bound := Prefix_Val; + end; + when Iir_Kind_Reverse_Range_Array_Attribute => + declare + Dim : Iir_Int64; + begin + Dim := Get_Value (Get_Parameter (Prefix)); + Bound := Execute_Indexes (Block, Get_Prefix (Prefix), Dim); + case Bound.Dir is + when Iir_To => + Bound := Create_Range_Value + (Bound.Right, Bound.Left, Iir_Downto, Bound.Length); + when Iir_Downto => + Bound := Create_Range_Value + (Bound.Right, Bound.Left, Iir_To, Bound.Length); + end case; + end; + + when Iir_Kind_Floating_Type_Definition + | Iir_Kind_Integer_Type_Definition => + return Execute_Bounds + (Block, + Get_Range_Constraint (Get_Type (Get_Type_Declarator (Prefix)))); + + when Iir_Kinds_Denoting_Name => + return Execute_Bounds (Block, Get_Named_Entity (Prefix)); + + when others => + -- Error_Kind ("execute_bounds", Get_Kind (Prefix)); + declare + Prefix_Val: Iir_Value_Literal_Acc; + begin + Prefix_Val := Execute_Expression (Block, Prefix); + Bound := Prefix_Val.Bounds.D (1); + end; + end case; + if not Bound.Dir'Valid then + raise Internal_Error; + end if; + return Bound; + end Execute_Bounds; + + -- Perform type conversion as desribed in LRM93 7.3.5 + function Execute_Type_Conversion (Block: Block_Instance_Acc; + Conv : Iir_Type_Conversion; + Val : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc + is + Target_Type : constant Iir := Get_Type (Conv); + Res: Iir_Value_Literal_Acc; + begin + Res := Val; + case Get_Kind (Target_Type) is + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Integer_Subtype_Definition => + case Res.Kind is + when Iir_Value_I64 => + null; + when Iir_Value_F64 => + if Res.F64 > Ghdl_F64 (Iir_Int64'Last) or + Res.F64 < Ghdl_F64 (Iir_Int64'First) + then + Error_Msg_Constraint (Conv); + end if; + Res := Create_I64_Value (Ghdl_I64 (Res.F64)); + when Iir_Value_B1 + | Iir_Value_E32 + | Iir_Value_Range + | Iir_Value_Array + | Iir_Value_Signal + | Iir_Value_Record + | Iir_Value_Access + | Iir_Value_File + | Iir_Value_Protected + | Iir_Value_Quantity + | Iir_Value_Terminal => + -- These values are not of abstract numeric type. + raise Internal_Error; + end case; + when Iir_Kind_Floating_Type_Definition + | Iir_Kind_Floating_Subtype_Definition => + case Res.Kind is + when Iir_Value_F64 => + null; + when Iir_Value_I64 => + Res := Create_F64_Value (Ghdl_F64 (Res.I64)); + when Iir_Value_B1 + | Iir_Value_E32 + | Iir_Value_Range + | Iir_Value_Array + | Iir_Value_Signal + | Iir_Value_Record + | Iir_Value_Access + | Iir_Value_File + | Iir_Value_Protected + | Iir_Value_Quantity + | Iir_Value_Terminal => + -- These values are not of abstract numeric type. + raise Internal_Error; + end case; + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + -- must be same type. + null; + when Iir_Kind_Array_Type_Definition => + -- LRM93 7.3.5 + -- if the type mark denotes an unconstrained array type and the + -- operand is not a null array, then for each index position, the + -- bounds of the result are obtained by converting the bounds of + -- the operand to the corresponding index type of the target type. + -- FIXME: what is bound conversion ?? + null; + when Iir_Kind_Array_Subtype_Definition => + -- LRM93 7.3.5 + -- If the type mark denotes a constrained array subtype, then the + -- bounds of the result are those imposed by the type mark. + Implicit_Array_Conversion (Block, Res, Target_Type, Conv); + when others => + Error_Kind ("execute_type_conversion", Target_Type); + end case; + Check_Constraints (Block, Res, Target_Type, Conv); + return Res; + end Execute_Type_Conversion; + + -- Decrement VAL. + -- May raise a constraint error using EXPR. + function Execute_Dec (Val : Iir_Value_Literal_Acc; Expr : Iir) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + begin + case Val.Kind is + when Iir_Value_B1 => + if Val.B1 = False then + Error_Msg_Constraint (Expr); + end if; + Res := Create_B1_Value (False); + when Iir_Value_E32 => + if Val.E32 = 0 then + Error_Msg_Constraint (Expr); + end if; + Res := Create_E32_Value (Val.E32 - 1); + when Iir_Value_I64 => + if Val.I64 = Ghdl_I64'First then + Error_Msg_Constraint (Expr); + end if; + Res := Create_I64_Value (Val.I64 - 1); + when others => + raise Internal_Error; + end case; + return Res; + end Execute_Dec; + + -- Increment VAL. + -- May raise a constraint error using EXPR. + function Execute_Inc (Val : Iir_Value_Literal_Acc; Expr : Iir) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + begin + case Val.Kind is + when Iir_Value_B1 => + if Val.B1 = True then + Error_Msg_Constraint (Expr); + end if; + Res := Create_B1_Value (True); + when Iir_Value_E32 => + if Val.E32 = Ghdl_E32'Last then + Error_Msg_Constraint (Expr); + end if; + Res := Create_E32_Value (Val.E32 + 1); + when Iir_Value_I64 => + if Val.I64 = Ghdl_I64'Last then + Error_Msg_Constraint (Expr); + end if; + Res := Create_I64_Value (Val.I64 + 1); + when others => + raise Internal_Error; + end case; + return Res; + end Execute_Inc; + + function Execute_Expression_With_Type + (Block: Block_Instance_Acc; + Expr: Iir; + Expr_Type : Iir) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + begin + if Get_Kind (Expr) = Iir_Kind_Aggregate + and then not Is_Fully_Constrained_Type (Get_Type (Expr)) + then + return Execute_Aggregate (Block, Expr, Expr_Type); + else + Res := Execute_Expression (Block, Expr); + Implicit_Array_Conversion (Block, Res, Expr_Type, Expr); + Check_Constraints (Block, Res, Expr_Type, Expr); + return Res; + end if; + end Execute_Expression_With_Type; + + function Execute_Signal_Init_Value (Block : Block_Instance_Acc; Expr : Iir) + return Iir_Value_Literal_Acc + is + Base : constant Iir := Get_Object_Prefix (Expr); + Info : constant Sim_Info_Acc := Get_Info (Base); + Bblk : Block_Instance_Acc; + Base_Val : Iir_Value_Literal_Acc; + Res : Iir_Value_Literal_Acc; + Is_Sig : Boolean; + begin + Bblk := Get_Instance_By_Scope_Level (Block, Info.Scope_Level); + Base_Val := Bblk.Objects (Info.Slot + 1); + Execute_Name_With_Base (Block, Expr, Base_Val, Res, Is_Sig); + pragma Assert (Is_Sig); + return Res; + end Execute_Signal_Init_Value; + + procedure Execute_Name_With_Base (Block: Block_Instance_Acc; + Expr: Iir; + Base : Iir_Value_Literal_Acc; + Res : out Iir_Value_Literal_Acc; + Is_Sig : out Boolean) + is + Slot_Block: Block_Instance_Acc; + begin + -- Default value + Is_Sig := False; + + case Get_Kind (Expr) is + when Iir_Kind_Signal_Interface_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Delayed_Attribute + | Iir_Kind_Transaction_Attribute => + Is_Sig := True; + if Base /= null then + Res := Base; + else + Slot_Block := Get_Instance_For_Slot (Block, Expr); + Res := Slot_Block.Objects (Get_Info (Expr).Slot); + end if; + + when Iir_Kind_Object_Alias_Declaration => + pragma Assert (Base = null); + -- FIXME: add a flag ? + case Get_Kind (Get_Object_Prefix (Expr)) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Signal_Interface_Declaration + | Iir_Kind_Guard_Signal_Declaration => + Is_Sig := True; + when others => + Is_Sig := False; + end case; + Slot_Block := Get_Instance_For_Slot (Block, Expr); + Res := Slot_Block.Objects (Get_Info (Expr).Slot); + + when Iir_Kind_Constant_Interface_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Variable_Interface_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_File_Interface_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Attribute_Value + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Terminal_Declaration + | Iir_Kinds_Quantity_Declaration => + if Base /= null then + Res := Base; + else + declare + Info : constant Sim_Info_Acc := Get_Info (Expr); + begin + Slot_Block := + Get_Instance_By_Scope_Level (Block, Info.Scope_Level); + Res := Slot_Block.Objects (Info.Slot); + end; + end if; + + when Iir_Kind_Indexed_Name => + declare + Prefix: Iir; + Index_List: Iir_List; + Index: Iir; + Nbr_Dimensions: Iir_Index32; + Value: Iir_Value_Literal_Acc; + Pfx: Iir_Value_Literal_Acc; + Pos, Off : Iir_Index32; + begin + Prefix := Get_Prefix (Expr); + Index_List := Get_Index_List (Expr); + Nbr_Dimensions := Iir_Index32 (Get_Nbr_Elements (Index_List)); + Execute_Name_With_Base (Block, Prefix, Base, Pfx, Is_Sig); + for I in 1 .. Nbr_Dimensions loop + Index := Get_Nth_Element (Index_List, Natural (I - 1)); + Value := Execute_Expression (Block, Index); + Off := Get_Index_Offset (Value, Pfx.Bounds.D (I), Expr); + if I = 1 then + Pos := Off; + else + Pos := Pos * Pfx.Bounds.D (I).Length + Off; + end if; + end loop; + Res := Pfx.Val_Array.V (1 + Pos); + -- FIXME: free PFX. + end; + + when Iir_Kind_Slice_Name => + declare + Prefix: Iir; + Prefix_Array: Iir_Value_Literal_Acc; + + Srange : Iir_Value_Literal_Acc; + Index_Order : Order; + -- Lower and upper bounds of the slice. + Low, High: Iir_Index32; + begin + Srange := Execute_Bounds (Block, Get_Suffix (Expr)); + + Prefix := Get_Prefix (Expr); + + Execute_Name_With_Base + (Block, Prefix, Base, Prefix_Array, Is_Sig); + if Prefix_Array = null then + raise Internal_Error; + end if; + + -- LRM93 6.5 + -- It is an error if the direction of the discrete range is not + -- the same as that of the index range of the array denoted by + -- the prefix of the slice name. + if Srange.Dir /= Prefix_Array.Bounds.D (1).Dir then + Error_Msg_Exec ("slice direction mismatch", Expr); + end if; + + -- LRM93 6.5 + -- It is an error if either of the bounds of the + -- discrete range does not belong to the index range of the + -- prefixing array, unless the slice is a null slice. + Index_Order := Compare_Value (Srange.Left, Srange.Right); + if (Srange.Dir = Iir_To and Index_Order = Greater) + or (Srange.Dir = Iir_Downto and Index_Order = Less) + then + -- Null slice. + Low := 1; + High := 0; + else + Low := Get_Index_Offset + (Srange.Left, Prefix_Array.Bounds.D (1), Expr); + High := Get_Index_Offset + (Srange.Right, Prefix_Array.Bounds.D (1), Expr); + end if; + Res := Create_Array_Value (High - Low + 1, 1); + Res.Bounds.D (1) := Srange; + for I in Low .. High loop + Res.Val_Array.V (1 + I - Low) := + Prefix_Array.Val_Array.V (1 + I); + end loop; + end; + + when Iir_Kind_Selected_Element => + declare + Prefix: Iir_Value_Literal_Acc; + Pos: Iir_Index32; + begin + Execute_Name_With_Base + (Block, Get_Prefix (Expr), Base, Prefix, Is_Sig); + Pos := Get_Element_Position (Get_Selected_Element (Expr)); + Res := Prefix.Val_Record.V (Pos + 1); + end; + + when Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference => + declare + Prefix: Iir_Value_Literal_Acc; + begin + Prefix := Execute_Name (Block, Get_Prefix (Expr)); + Res := Prefix.Val_Access; + if Res = null then + Error_Msg_Exec ("deferencing null access", Expr); + end if; + end; + + when Iir_Kinds_Denoting_Name + | Iir_Kind_Attribute_Name => + Execute_Name_With_Base + (Block, Get_Named_Entity (Expr), Base, Res, Is_Sig); + + when Iir_Kind_Function_Call => + -- A prefix can be an expression + if Base /= null then + raise Internal_Error; + end if; + Res := Execute_Expression (Block, Expr); + + when Iir_Kind_Aggregate => + Res := Execute_Name_Aggregate (Block, Expr, Get_Type (Expr)); + -- FIXME: is_sig ? + + when others => + Error_Kind ("execute_name_with_base", Expr); + end case; + end Execute_Name_With_Base; + + function Execute_Name (Block: Block_Instance_Acc; + Expr: Iir; + Ref : Boolean := False) + return Iir_Value_Literal_Acc + is + Res: Iir_Value_Literal_Acc; + Is_Sig : Boolean; + begin + Execute_Name_With_Base (Block, Expr, null, Res, Is_Sig); + if not Is_Sig or else Ref then + return Res; + else + return Execute_Signal_Value (Res); + end if; + end Execute_Name; + + function Execute_Image_Attribute (Block: Block_Instance_Acc; Expr: Iir) + return Iir_Value_Literal_Acc + is + Val : Iir_Value_Literal_Acc; + Attr_Type : constant Iir := Get_Type (Get_Prefix (Expr)); + begin + Val := Execute_Expression (Block, Get_Parameter (Expr)); + return String_To_Iir_Value + (Execute_Image_Attribute (Val, Attr_Type)); + end Execute_Image_Attribute; + + function Execute_Value_Attribute (Block: Block_Instance_Acc; + Str_Val : Iir_Value_Literal_Acc; + Expr: Iir) + return Iir_Value_Literal_Acc + is + use Grt_Interface; + use Name_Table; + pragma Unreferenced (Block); + + Expr_Type : constant Iir := Get_Type (Expr); + Res : Iir_Value_Literal_Acc; + + Str_Bnd : aliased Std_String_Bound := Build_Bound (Str_Val); + Str_Str : aliased Std_String_Uncons (1 .. Str_Bnd.Dim_1.Length); + Str : aliased Std_String := (To_Std_String_Basep (Str_Str'Address), + To_Std_String_Boundp (Str_Bnd'Address)); + begin + Set_Std_String_From_Iir_Value (Str, Str_Val); + case Get_Kind (Expr_Type) is + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Integer_Subtype_Definition => + Res := Create_I64_Value + (Grt.Values.Ghdl_Value_I64 (Str'Unrestricted_Access)); + when Iir_Kind_Floating_Type_Definition + | Iir_Kind_Floating_Subtype_Definition => + Res := Create_F64_Value + (Grt.Values.Ghdl_Value_F64 (Str'Unrestricted_Access)); + when Iir_Kind_Physical_Type_Definition + | Iir_Kind_Physical_Subtype_Definition => + declare + Is_Real : Boolean; + Lit_Pos : Ghdl_Index_Type; + Lit_End : Ghdl_Index_Type; + Unit_Pos : Ghdl_Index_Type; + Unit_Len : Ghdl_Index_Type; + Mult : Ghdl_I64; + Unit : Iir; + Unit_Id : Name_Id; + begin + Grt.Values.Ghdl_Value_Physical_Split + (Str'Unrestricted_Access, + Is_Real, Lit_Pos, Lit_End, Unit_Pos); + + -- Find unit. + Unit_Len := 0; + Unit_Pos := Unit_Pos + 1; -- From 0 based to 1 based + for I in Unit_Pos .. Str_Bnd.Dim_1.Length loop + exit when Grt.Values.Is_Whitespace (Str_Str (I)); + Unit_Len := Unit_Len + 1; + Str_Str (I) := Grt.Values.To_LC (Str_Str (I)); + end loop; + + Unit := Get_Primary_Unit (Expr_Type); + while Unit /= Null_Iir loop + Unit_Id := Get_Identifier (Unit); + exit when Get_Name_Length (Unit_Id) = Natural (Unit_Len) + and then Image (Unit_Id) = + String (Str_Str (Unit_Pos .. Unit_Pos + Unit_Len - 1)); + Unit := Get_Chain (Unit); + end loop; + + if Unit = Null_Iir then + Error_Msg_Exec ("incorrect unit name", Expr); + end if; + Mult := Ghdl_I64 (Get_Value (Get_Physical_Unit_Value (Unit))); + + Str_Bnd.Dim_1.Length := Lit_End; + if Is_Real then + Res := Create_I64_Value + (Ghdl_I64 + (Grt.Values.Ghdl_Value_F64 (Str'Unrestricted_Access) + * Ghdl_F64 (Mult))); + else + Res := Create_I64_Value + (Grt.Values.Ghdl_Value_I64 (Str'Unrestricted_Access) + * Mult); + end if; + end; + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + declare + Lit_Start : Ghdl_Index_Type; + Lit_End : Ghdl_Index_Type; + Enums : constant Iir_List := + Get_Enumeration_Literal_List (Get_Base_Type (Expr_Type)); + Enum : Iir; + Enum_Id : Name_Id; + begin + -- Remove leading and trailing blanks + for I in Str_Str'Range loop + if not Grt.Values.Is_Whitespace (Str_Str (I)) then + Lit_Start := I; + exit; + end if; + end loop; + for I in reverse Lit_Start .. Str_Str'Last loop + if not Grt.Values.Is_Whitespace (Str_Str (I)) then + Lit_End := I; + exit; + end if; + end loop; + + -- Convert to lower case. + for I in Lit_Start .. Lit_End loop + Str_Str (I) := Grt.Values.To_LC (Str_Str (I)); + end loop; + + for I in Natural loop + Enum := Get_Nth_Element (Enums, I); + if Enum = Null_Iir then + Error_Msg_Exec ("incorrect unit name", Expr); + end if; + Enum_Id := Get_Identifier (Enum); + exit when (Get_Name_Length (Enum_Id) = + Natural (Lit_End - Lit_Start + 1)) + and then (Image (Enum_Id) = + String (Str_Str (Lit_Start .. Lit_End))); + end loop; + + return Create_Enum_Value + (Natural (Get_Enum_Pos (Enum)), Expr_Type); + end; + when others => + Error_Kind ("value_attribute", Expr_Type); + end case; + return Res; + end Execute_Value_Attribute; + + function Execute_Path_Instance_Name_Attribute + (Block : Block_Instance_Acc; Attr : Iir) + return Iir_Value_Literal_Acc + is + use Evaluation; + use Grt.Vstrings; + use Name_Table; + + Name : constant Path_Instance_Name_Type := + Get_Path_Instance_Name_Suffix (Attr); + Instance : Block_Instance_Acc; + Rstr : Rstring; + Is_Instance : constant Boolean := + Get_Kind (Attr) = Iir_Kind_Instance_Name_Attribute; + begin + if Name.Path_Instance = Null_Iir then + return String_To_Iir_Value (Name.Suffix); + end if; + + Instance := Get_Instance_By_Scope_Level + (Block, Get_Info (Name.Path_Instance).Frame_Scope_Level); + + loop + case Get_Kind (Instance.Label) is + when Iir_Kind_Entity_Declaration => + if Instance.Parent = null then + Prepend (Rstr, Image (Get_Identifier (Instance.Label))); + exit; + end if; + when Iir_Kind_Architecture_Body => + if Is_Instance then + Prepend (Rstr, ')'); + Prepend (Rstr, Image (Get_Identifier (Instance.Label))); + Prepend (Rstr, '('); + end if; + + if Is_Instance or else Instance.Parent = null then + Prepend + (Rstr, + Image (Get_Identifier (Get_Entity (Instance.Label)))); + end if; + if Instance.Parent = null then + Prepend (Rstr, ':'); + exit; + else + Instance := Instance.Parent; + end if; + when Iir_Kind_Block_Statement => + Prepend (Rstr, Image (Get_Label (Instance.Label))); + Prepend (Rstr, ':'); + Instance := Instance.Parent; + when Iir_Kind_Iterator_Declaration => + declare + Val : Iir_Value_Literal_Acc; + begin + Val := Execute_Name (Instance, Instance.Label); + Prepend (Rstr, ')'); + Prepend (Rstr, Execute_Image_Attribute + (Val, Get_Type (Instance.Label))); + Prepend (Rstr, '('); + end; + Instance := Instance.Parent; + when Iir_Kind_Generate_Statement => + Prepend (Rstr, Image (Get_Label (Instance.Label))); + Prepend (Rstr, ':'); + Instance := Instance.Parent; + when Iir_Kind_Component_Instantiation_Statement => + if Is_Instance then + Prepend (Rstr, '@'); + end if; + Prepend (Rstr, Image (Get_Label (Instance.Label))); + Prepend (Rstr, ':'); + Instance := Instance.Parent; + when others => + Error_Kind ("Execute_Path_Instance_Name_Attribute", + Instance.Label); + end case; + end loop; + declare + Str1 : String (1 .. Length (Rstr)); + Len1 : Natural; + begin + Copy (Rstr, Str1, Len1); + Free (Rstr); + return String_To_Iir_Value (Str1 & ':' & Name.Suffix); + end; + end Execute_Path_Instance_Name_Attribute; + + -- For 'Last_Event and 'Last_Active: convert the absolute last time to + -- a relative delay. + function To_Relative_Time (T : Ghdl_I64) return Iir_Value_Literal_Acc is + A : Ghdl_I64; + begin + if T = -Ghdl_I64'Last then + A := Ghdl_I64'Last; + else + A := Ghdl_I64 (Grt.Types.Current_Time) - T; + end if; + return Create_I64_Value (A); + end To_Relative_Time; + + -- Evaluate an expression. + function Execute_Expression (Block: Block_Instance_Acc; Expr: Iir) + return Iir_Value_Literal_Acc + is + Res: Iir_Value_Literal_Acc; + begin + case Get_Kind (Expr) is + when Iir_Kind_Signal_Interface_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Delayed_Attribute + | Iir_Kind_Transaction_Attribute + | Iir_Kind_Object_Alias_Declaration => + Res := Execute_Name (Block, Expr); + return Res; + + when Iir_Kind_Constant_Interface_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Variable_Interface_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_File_Interface_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Attribute_Value + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name + | Iir_Kind_Selected_Element + | Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference => + return Execute_Name (Block, Expr); + + when Iir_Kinds_Denoting_Name + | Iir_Kind_Attribute_Name => + return Execute_Expression (Block, Get_Named_Entity (Expr)); + + when Iir_Kind_Aggregate => + return Execute_Aggregate (Block, Expr, Get_Type (Expr)); + when Iir_Kind_Simple_Aggregate => + return Execute_Simple_Aggregate (Block, Expr); + + when Iir_Kinds_Dyadic_Operator + | Iir_Kinds_Monadic_Operator => + declare + Imp : Iir; + begin + Imp := Get_Implementation (Expr); + if Get_Kind (Imp) = Iir_Kind_Function_Declaration then + return Execute_Function_Call (Block, Expr, Imp); + else + if Get_Kind (Expr) in Iir_Kinds_Dyadic_Operator then + Res := Execute_Implicit_Function + (Block, Expr, Get_Left (Expr), Get_Right (Expr), + Get_Type (Expr)); + else + Res := Execute_Implicit_Function + (Block, Expr, Get_Operand (Expr), Null_Iir, + Get_Type (Expr)); + end if; + return Res; + end if; + end; + + when Iir_Kind_Function_Call => + declare + Imp : constant Iir := + Get_Named_Entity (Get_Implementation (Expr)); + Assoc : Iir; + Args : Iir_Array (0 .. 1); + begin + if Get_Kind (Imp) = Iir_Kind_Function_Declaration then + return Execute_Function_Call (Block, Expr, Imp); + else + Assoc := Get_Parameter_Association_Chain (Expr); + if Assoc /= Null_Iir then + Args (0) := Get_Actual (Assoc); + Assoc := Get_Chain (Assoc); + else + Args (0) := Null_Iir; + end if; + if Assoc /= Null_Iir then + Args (1) := Get_Actual (Assoc); + else + Args (1) := Null_Iir; + end if; + return Execute_Implicit_Function + (Block, Expr, Args (0), Args (1), Get_Type (Expr)); + end if; + end; + + when Iir_Kind_Integer_Literal => + declare + Lit_Type : constant Iir := Get_Base_Type (Get_Type (Expr)); + Lit : constant Iir_Int64 := Get_Value (Expr); + begin + case Get_Info (Lit_Type).Scalar_Mode is + when Iir_Value_I64 => + return Create_I64_Value (Ghdl_I64 (Lit)); + when others => + raise Internal_Error; + end case; + end; + + when Iir_Kind_Floating_Point_Literal => + return Create_F64_Value (Ghdl_F64 (Get_Fp_Value (Expr))); + + when Iir_Kind_Enumeration_Literal => + declare + Lit_Type : constant Iir := Get_Base_Type (Get_Type (Expr)); + Lit : constant Iir_Int32 := Get_Enum_Pos (Expr); + begin + case Get_Info (Lit_Type).Scalar_Mode is + when Iir_Value_B1 => + return Create_B1_Value (Ghdl_B1'Val (Lit)); + when Iir_Value_E32 => + return Create_E32_Value (Ghdl_E32 (Lit)); + when others => + raise Internal_Error; + end case; + end; + + when Iir_Kind_Physical_Int_Literal + | Iir_Kind_Physical_Fp_Literal + | Iir_Kind_Unit_Declaration => + return Create_I64_Value + (Ghdl_I64 (Evaluation.Get_Physical_Value (Expr))); + + when Iir_Kind_String_Literal + | Iir_Kind_Bit_String_Literal => + return String_To_Enumeration_Array (Block, Expr); + + when Iir_Kind_Null_Literal => + return Null_Lit; + + when Iir_Kind_Overflow_Literal => + Error_Msg_Constraint (Expr); + return null; + + when Iir_Kind_Parenthesis_Expression => + return Execute_Expression (Block, Get_Expression (Expr)); + + when Iir_Kind_Type_Conversion => + return Execute_Type_Conversion + (Block, Expr, + Execute_Expression (Block, Get_Expression (Expr))); + + when Iir_Kind_Qualified_Expression => + Res := Execute_Expression_With_Type + (Block, Get_Expression (Expr), Get_Type (Get_Type_Mark (Expr))); + return Res; + + when Iir_Kind_Allocator_By_Expression => + Res := Execute_Expression (Block, Get_Expression (Expr)); + Res := Unshare_Heap (Res); + return Create_Access_Value (Res); + + when Iir_Kind_Allocator_By_Subtype => + Res := Create_Value_For_Type + (Block, + Get_Type_Of_Subtype_Indication (Get_Subtype_Indication (Expr)), + True); + Res := Unshare_Heap (Res); + return Create_Access_Value (Res); + + when Iir_Kind_Left_Type_Attribute => + Res := Execute_Bounds (Block, Get_Prefix (Expr)); + return Execute_Left_Limit (Res); + + when Iir_Kind_Right_Type_Attribute => + Res := Execute_Bounds (Block, Get_Prefix (Expr)); + return Execute_Right_Limit (Res); + + when Iir_Kind_High_Type_Attribute => + Res := Execute_Bounds (Block, Get_Prefix (Expr)); + return Execute_High_Limit (Res); + + when Iir_Kind_Low_Type_Attribute => + Res := Execute_Bounds (Block, Get_Prefix (Expr)); + return Execute_Low_Limit (Res); + + when Iir_Kind_High_Array_Attribute => + Res := Execute_Indexes + (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr))); + return Execute_High_Limit (Res); + + when Iir_Kind_Low_Array_Attribute => + Res := Execute_Indexes + (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr))); + return Execute_Low_Limit (Res); + + when Iir_Kind_Left_Array_Attribute => + Res := Execute_Indexes + (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr))); + return Execute_Left_Limit (Res); + + when Iir_Kind_Right_Array_Attribute => + Res := Execute_Indexes + (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr))); + return Execute_Right_Limit (Res); + + when Iir_Kind_Length_Array_Attribute => + Res := Execute_Indexes + (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr))); + return Execute_Length (Res); + + when Iir_Kind_Ascending_Array_Attribute => + Res := Execute_Indexes + (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr))); + return Boolean_To_Lit (Res.Dir = Iir_To); + + when Iir_Kind_Event_Attribute => + Res := Execute_Name (Block, Get_Prefix (Expr), True); + return Boolean_To_Lit (Execute_Event_Attribute (Res)); + + when Iir_Kind_Active_Attribute => + Res := Execute_Name (Block, Get_Prefix (Expr), True); + return Boolean_To_Lit (Execute_Active_Attribute (Res)); + + when Iir_Kind_Driving_Attribute => + Res := Execute_Name (Block, Get_Prefix (Expr), True); + return Boolean_To_Lit (Execute_Driving_Attribute (Res)); + + when Iir_Kind_Last_Value_Attribute => + Res := Execute_Name (Block, Get_Prefix (Expr), True); + return Execute_Last_Value_Attribute (Res); + + when Iir_Kind_Driving_Value_Attribute => + Res := Execute_Name (Block, Get_Prefix (Expr), True); + return Execute_Driving_Value_Attribute (Res); + + when Iir_Kind_Last_Event_Attribute => + Res := Execute_Name (Block, Get_Prefix (Expr), True); + return To_Relative_Time (Execute_Last_Event_Attribute (Res)); + + when Iir_Kind_Last_Active_Attribute => + Res := Execute_Name (Block, Get_Prefix (Expr), True); + return To_Relative_Time (Execute_Last_Active_Attribute (Res)); + + when Iir_Kind_Val_Attribute => + declare + Prefix_Type: constant Iir := Get_Type (Get_Prefix (Expr)); + Base_Type : constant Iir := Get_Base_Type (Prefix_Type); + Mode : constant Iir_Value_Kind := + Get_Info (Base_Type).Scalar_Mode; + begin + Res := Execute_Expression (Block, Get_Parameter (Expr)); + case Mode is + when Iir_Value_I64 => + null; + when Iir_Value_E32 => + Res := Create_E32_Value (Ghdl_E32 (Res.I64)); + when Iir_Value_B1 => + Res := Create_B1_Value (Ghdl_B1'Val (Res.I64)); + when others => + Error_Kind ("execute_expression(val attribute)", + Prefix_Type); + end case; + Check_Constraints (Block, Res, Prefix_Type, Expr); + return Res; + end; + + when Iir_Kind_Pos_Attribute => + declare + N_Res: Iir_Value_Literal_Acc; + Prefix_Type: constant Iir := Get_Type (Get_Prefix (Expr)); + Base_Type : constant Iir := Get_Base_Type (Prefix_Type); + Mode : constant Iir_Value_Kind := + Get_Info (Base_Type).Scalar_Mode; + begin + Res := Execute_Expression (Block, Get_Parameter (Expr)); + case Mode is + when Iir_Value_I64 => + null; + when Iir_Value_B1 => + N_Res := Create_I64_Value (Ghdl_B1'Pos (Res.B1)); + Res := N_Res; + when Iir_Value_E32 => + N_Res := Create_I64_Value (Ghdl_I64 (Res.E32)); + Res := N_Res; + when others => + Error_Kind ("execute_expression(pos attribute)", + Base_Type); + end case; + Check_Constraints (Block, Res, Get_Type (Expr), Expr); + return Res; + end; + + when Iir_Kind_Succ_Attribute => + Res := Execute_Expression (Block, Get_Parameter (Expr)); + Res := Execute_Inc (Res, Expr); + Check_Constraints (Block, Res, Get_Type (Expr), Expr); + return Res; + + when Iir_Kind_Pred_Attribute => + Res := Execute_Expression (Block, Get_Parameter (Expr)); + Res := Execute_Dec (Res, Expr); + Check_Constraints (Block, Res, Get_Type (Expr), Expr); + return Res; + + when Iir_Kind_Leftof_Attribute => + declare + Bound : Iir_Value_Literal_Acc; + begin + Res := Execute_Expression (Block, Get_Parameter (Expr)); + Bound := Execute_Bounds + (Block, Get_Type (Get_Prefix (Expr))); + case Bound.Dir is + when Iir_To => + Res := Execute_Dec (Res, Expr); + when Iir_Downto => + Res := Execute_Inc (Res, Expr); + end case; + Check_Constraints (Block, Res, Get_Type (Expr), Expr); + return Res; + end; + + when Iir_Kind_Rightof_Attribute => + declare + Bound : Iir_Value_Literal_Acc; + begin + Res := Execute_Expression (Block, Get_Parameter (Expr)); + Bound := Execute_Bounds + (Block, Get_Type (Get_Prefix (Expr))); + case Bound.Dir is + when Iir_Downto => + Res := Execute_Dec (Res, Expr); + when Iir_To => + Res := Execute_Inc (Res, Expr); + end case; + Check_Constraints (Block, Res, Get_Type (Expr), Expr); + return Res; + end; + + when Iir_Kind_Image_Attribute => + return Execute_Image_Attribute (Block, Expr); + + when Iir_Kind_Value_Attribute => + Res := Execute_Expression (Block, Get_Parameter (Expr)); + return Execute_Value_Attribute (Block, Res, Expr); + + when Iir_Kind_Path_Name_Attribute + | Iir_Kind_Instance_Name_Attribute => + return Execute_Path_Instance_Name_Attribute (Block, Expr); + + when others => + Error_Kind ("execute_expression", Expr); + end case; + end Execute_Expression; + + procedure Execute_Dyadic_Association + (Out_Block: Block_Instance_Acc; + In_Block: Block_Instance_Acc; + Expr : Iir; + Inter_Chain: Iir) + is + Inter: Iir; + Val: Iir_Value_Literal_Acc; + begin + Inter := Inter_Chain; + for I in 0 .. 1 loop + if I = 0 then + Val := Execute_Expression (Out_Block, Get_Left (Expr)); + else + Val := Execute_Expression (Out_Block, Get_Right (Expr)); + end if; + Implicit_Array_Conversion (In_Block, Val, Get_Type (Inter), Expr); + Check_Constraints (In_Block, Val, Get_Type (Inter), Expr); + + Elaboration.Create_Object (In_Block, Inter); + In_Block.Objects (Get_Info (Inter).Slot) := + Unshare (Val, Instance_Pool); + Inter := Get_Chain (Inter); + end loop; + end Execute_Dyadic_Association; + + procedure Execute_Monadic_Association + (Out_Block: Block_Instance_Acc; + In_Block: Block_Instance_Acc; + Expr : Iir; + Inter: Iir) + is + Val: Iir_Value_Literal_Acc; + begin + Val := Execute_Expression (Out_Block, Get_Operand (Expr)); + Implicit_Array_Conversion (In_Block, Val, Get_Type (Inter), Expr); + Check_Constraints (In_Block, Val, Get_Type (Inter), Expr); + + Elaboration.Create_Object (In_Block, Inter); + In_Block.Objects (Get_Info (Inter).Slot) := + Unshare (Val, Instance_Pool); + end Execute_Monadic_Association; + + -- Create a block instance for subprogram IMP. + function Create_Subprogram_Instance (Instance : Block_Instance_Acc; + Imp : Iir) + return Block_Instance_Acc + is + Func_Info : constant Sim_Info_Acc := Get_Info (Imp); + + subtype Block_Type is Block_Instance_Type (Func_Info.Nbr_Objects); + function To_Block_Instance_Acc is new + Ada.Unchecked_Conversion (System.Address, Block_Instance_Acc); + function Alloc_Block_Instance is new + Alloc_On_Pool_Addr (Block_Type); + + Up_Block: Block_Instance_Acc; + Res : Block_Instance_Acc; + begin + Up_Block := Get_Instance_By_Scope_Level + (Instance, Func_Info.Frame_Scope_Level - 1); + + Res := To_Block_Instance_Acc + (Alloc_Block_Instance + (Instance_Pool, + Block_Instance_Type'(Max_Objs => Func_Info.Nbr_Objects, + Scope_Level => Func_Info.Frame_Scope_Level, + Up_Block => Up_Block, + Label => Imp, + Stmt => Null_Iir, + Parent => Instance, + Children => null, + Brother => null, + Marker => Empty_Marker, + Objects => (others => null), + Elab_Objects => 0, + In_Wait_Flag => False, + Actuals_Ref => null, + Result => null))); + return Res; + end Create_Subprogram_Instance; + + -- Destroy a dynamic block_instance. + procedure Execute_Subprogram_Call_Final (Instance : Block_Instance_Acc) + is + Subprg_Body : constant Iir := Get_Subprogram_Body (Instance.Label); + begin + Finalize_Declarative_Part + (Instance, Get_Declaration_Chain (Subprg_Body)); + end Execute_Subprogram_Call_Final; + + function Execute_Function_Body (Instance : Block_Instance_Acc; Func : Iir) + return Iir_Value_Literal_Acc + is + Subprg_Body : constant Iir := Get_Subprogram_Body (Func); + Res : Iir_Value_Literal_Acc; + begin + Current_Process.Instance := Instance; + + Elaborate_Declarative_Part + (Instance, Get_Declaration_Chain (Subprg_Body)); + + -- execute statements + Instance.Stmt := Get_Sequential_Statement_Chain (Subprg_Body); + Execute_Sequential_Statements (Current_Process); + pragma Assert (Current_Process.Instance = Instance); + + if Instance.Result = null then + Error_Msg_Exec + ("function scope exited without a return statement", Func); + end if; + + -- Free variables, slots... + -- Need to copy the return value, because it can contains values from + -- arguments. + Res := Instance.Result; + + Current_Process.Instance := Instance.Parent; + Execute_Subprogram_Call_Final (Instance); + + return Res; + end Execute_Function_Body; + + function Execute_Assoc_Function_Conversion + (Block : Block_Instance_Acc; Func : Iir; Val : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc + is + Inter : Iir; + Instance : Block_Instance_Acc; + Res : Iir_Value_Literal_Acc; + Marker : Mark_Type; + begin + Mark (Marker, Instance_Pool.all); + + -- Create an instance for this function. + Instance := Create_Subprogram_Instance (Block, Func); + + Inter := Get_Interface_Declaration_Chain (Func); + Elaboration.Create_Object (Instance, Inter); + -- FIXME: implicit conversion + Instance.Objects (Get_Info (Inter).Slot) := Val; + + Res := Execute_Function_Body (Instance, Func); + Res := Unshare (Res, Expr_Pool'Access); + Release (Marker, Instance_Pool.all); + return Res; + end Execute_Assoc_Function_Conversion; + + function Execute_Assoc_Conversion + (Block : Block_Instance_Acc; Conv : Iir; Val : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc + is + Ent : Iir; + begin + case Get_Kind (Conv) is + when Iir_Kind_Function_Call => + -- FIXME: shouldn't CONV always be a denoting_name ? + return Execute_Assoc_Function_Conversion + (Block, Get_Named_Entity (Get_Implementation (Conv)), Val); + when Iir_Kind_Type_Conversion => + -- FIXME: shouldn't CONV always be a denoting_name ? + return Execute_Type_Conversion (Block, Conv, Val); + when Iir_Kinds_Denoting_Name => + Ent := Get_Named_Entity (Conv); + if Get_Kind (Ent) = Iir_Kind_Function_Declaration then + return Execute_Assoc_Function_Conversion (Block, Ent, Val); + elsif Get_Kind (Ent) in Iir_Kinds_Type_Declaration then + return Execute_Type_Conversion (Block, Ent, Val); + else + Error_Kind ("execute_assoc_conversion(1)", Ent); + end if; + when others => + Error_Kind ("execute_assoc_conversion(2)", Conv); + end case; + end Execute_Assoc_Conversion; + + -- Establish correspondance for association list ASSOC_LIST from block + -- instance OUT_BLOCK for subprogram of block SUBPRG_BLOCK. + procedure Execute_Association + (Out_Block: Block_Instance_Acc; + Subprg_Block: Block_Instance_Acc; + Assoc_Chain: Iir) + is + Nbr_Assoc : constant Natural := Get_Chain_Length (Assoc_Chain); + Assoc: Iir; + Actual : Iir; + Inter: Iir; + Formal : Iir; + Conv : Iir; + Val: Iir_Value_Literal_Acc; + Assoc_Idx : Iir_Index32; + Last_Individual : Iir_Value_Literal_Acc; + Mode : Iir_Mode; + Marker : Mark_Type; + begin + Subprg_Block.Actuals_Ref := null; + Mark (Marker, Expr_Pool); + + Assoc := Assoc_Chain; + Assoc_Idx := 1; + while Assoc /= Null_Iir loop + Formal := Get_Formal (Assoc); + Inter := Get_Association_Interface (Assoc); + + -- Extract the actual value. + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_Open => + -- Not allowed in individual association. + pragma Assert (Formal = Inter); + pragma Assert (Get_Whole_Association_Flag (Assoc)); + Actual := Get_Default_Value (Inter); + when Iir_Kind_Association_Element_By_Expression => + Actual := Get_Actual (Assoc); + when Iir_Kind_Association_Element_By_Individual => + -- FIXME: signals ? + pragma Assert + (Get_Kind (Inter) /= Iir_Kind_Signal_Interface_Declaration); + Last_Individual := Create_Value_For_Type + (Out_Block, Get_Actual_Type (Assoc), False); + Last_Individual := Unshare (Last_Individual, Instance_Pool); + + Elaboration.Create_Object (Subprg_Block, Inter); + Subprg_Block.Objects (Get_Info (Inter).Slot) := Last_Individual; + goto Continue; + when others => + Error_Kind ("execute_association(1)", Assoc); + end case; + + -- Compute actual value. + case Get_Kind (Inter) is + when Iir_Kind_Constant_Interface_Declaration + | Iir_Kind_File_Interface_Declaration => + Val := Execute_Expression (Out_Block, Actual); + Implicit_Array_Conversion + (Subprg_Block, Val, Get_Type (Formal), Assoc); + Check_Constraints (Subprg_Block, Val, Get_Type (Formal), Assoc); + when Iir_Kind_Signal_Interface_Declaration => + Val := Execute_Name (Out_Block, Actual, True); + Implicit_Array_Conversion + (Subprg_Block, Val, Get_Type (Formal), Assoc); + when Iir_Kind_Variable_Interface_Declaration => + Mode := Get_Mode (Inter); + if Mode = Iir_In_Mode then + -- FIXME: Ref ? + Val := Execute_Expression (Out_Block, Actual); + else + Val := Execute_Name (Out_Block, Actual, False); + end if; + + -- FIXME: by value for scalars ? + + -- Keep ref for back-copy + if Mode /= Iir_In_Mode then + if Subprg_Block.Actuals_Ref = null then + declare + subtype Actuals_Ref_Type is + Value_Array (Iir_Index32 (Nbr_Assoc)); + function To_Value_Array_Acc is new + Ada.Unchecked_Conversion (System.Address, + Value_Array_Acc); + function Alloc_Actuals_Ref is new + Alloc_On_Pool_Addr (Actuals_Ref_Type); + + begin + Subprg_Block.Actuals_Ref := To_Value_Array_Acc + (Alloc_Actuals_Ref + (Instance_Pool, + Actuals_Ref_Type'(Len => Iir_Index32 (Nbr_Assoc), + V => (others => null)))); + end; + end if; + Subprg_Block.Actuals_Ref.V (Assoc_Idx) := + Unshare_Bounds (Val, Instance_Pool); + end if; + + if Mode = Iir_Out_Mode then + if Get_Out_Conversion (Assoc) /= Null_Iir then + -- For an OUT variable using an out conversion, don't + -- associate with the actual, create a temporary value. + Val := Create_Value_For_Type + (Out_Block, Get_Type (Formal), True); + elsif Get_Kind (Get_Type (Formal)) in + Iir_Kinds_Scalar_Type_Definition + then + -- These are passed by value. Must be reset. + Val := Create_Value_For_Type + (Out_Block, Get_Type (Formal), True); + end if; + else + if Get_Kind (Assoc) = + Iir_Kind_Association_Element_By_Expression + then + Conv := Get_In_Conversion (Assoc); + if Conv /= Null_Iir then + Val := Execute_Assoc_Conversion + (Subprg_Block, Conv, Val); + end if; + end if; + + -- FIXME: check constraints ? + end if; + + Implicit_Array_Conversion + (Subprg_Block, Val, Get_Type (Formal), Assoc); + + when others => + Error_Kind ("execute_association(2)", Inter); + end case; + + if Get_Whole_Association_Flag (Assoc) then + case Get_Kind (Inter) is + when Iir_Kind_Constant_Interface_Declaration + | Iir_Kind_Variable_Interface_Declaration + | Iir_Kind_File_Interface_Declaration => + -- FIXME: Arguments are passed by copy. + Elaboration.Create_Object (Subprg_Block, Inter); + Subprg_Block.Objects (Get_Info (Inter).Slot) := + Unshare (Val, Instance_Pool); + when Iir_Kind_Signal_Interface_Declaration => + Elaboration.Create_Signal (Subprg_Block, Inter); + Subprg_Block.Objects (Get_Info (Inter).Slot) := + Unshare_Bounds (Val, Instance_Pool); + when others => + Error_Kind ("execute_association", Inter); + end case; + else + declare + Targ : Iir_Value_Literal_Acc; + Is_Sig : Boolean; + begin + Execute_Name_With_Base + (Subprg_Block, Formal, Last_Individual, Targ, Is_Sig); + Store (Targ, Val); + end; + end if; + + << Continue >> null; + Assoc := Get_Chain (Assoc); + Assoc_Idx := Assoc_Idx + 1; + end loop; + + Release (Marker, Expr_Pool); + end Execute_Association; + + procedure Execute_Back_Association (Instance : Block_Instance_Acc) + is + Proc : Iir; + Assoc: Iir; + Inter: Iir; + Formal : Iir; + Assoc_Idx : Iir_Index32; + begin + Proc := Get_Procedure_Call (Instance.Parent.Stmt); + Assoc := Get_Parameter_Association_Chain (Proc); + Assoc_Idx := 1; + while Assoc /= Null_Iir loop + if Get_Kind (Assoc) /= Iir_Kind_Association_Element_By_Individual then + Formal := Get_Formal (Assoc); + Inter := Get_Association_Interface (Assoc); + case Get_Kind (Inter) is + when Iir_Kind_Variable_Interface_Declaration => + if Get_Mode (Inter) /= Iir_In_Mode + and then Get_Kind (Get_Type (Inter)) /= + Iir_Kind_File_Type_Definition + then + -- For out/inout variable interface, the value must + -- be copied (FIXME: unless when passed by reference ?). + declare + Targ : constant Iir_Value_Literal_Acc := + Instance.Actuals_Ref.V (Assoc_Idx); + Base : constant Iir_Value_Literal_Acc := + Instance.Objects (Get_Info (Inter).Slot); + Val : Iir_Value_Literal_Acc; + Conv : Iir; + Is_Sig : Boolean; + Expr_Mark : Mark_Type; + begin + Mark (Expr_Mark, Expr_Pool); + + -- Extract for individual association. + Execute_Name_With_Base + (Instance, Formal, Base, Val, Is_Sig); + Conv := Get_Out_Conversion (Assoc); + if Conv /= Null_Iir then + Val := Execute_Assoc_Conversion + (Instance, Conv, Val); + -- FIXME: free val ? + end if; + Store (Targ, Val); + + Release (Expr_Mark, Expr_Pool); + end; + end if; + when Iir_Kind_File_Interface_Declaration => + null; + when Iir_Kind_Signal_Interface_Declaration + | Iir_Kind_Constant_Interface_Declaration => + null; + when others => + Error_Kind ("execute_back_association", Inter); + end case; + end if; + Assoc := Get_Chain (Assoc); + Assoc_Idx := Assoc_Idx + 1; + end loop; + end Execute_Back_Association; + + -- When a subprogram of a protected type is called, a link to the object + -- must be passed. This procedure modifies the up_link of SUBPRG_BLOCK to + -- point to the block of the object (extracted from CALL and BLOCK). + -- This change doesn't modify the parent (so that the activation chain is + -- not changed). + procedure Adjust_Up_Link_For_Protected_Object + (Block: Block_Instance_Acc; Call: Iir; Subprg_Block : Block_Instance_Acc) + is + Meth_Obj : constant Iir := Get_Method_Object (Call); + Obj : Iir_Value_Literal_Acc; + Obj_Block : Block_Instance_Acc; + begin + if Meth_Obj /= Null_Iir then + Obj := Execute_Name (Block, Meth_Obj, True); + Obj_Block := Protected_Table.Table (Obj.Prot); + Subprg_Block.Up_Block := Obj_Block; + end if; + end Adjust_Up_Link_For_Protected_Object; + + function Execute_Foreign_Function_Call + (Block: Block_Instance_Acc; Expr : Iir; Imp : Iir) + return Iir_Value_Literal_Acc + is + pragma Unreferenced (Block); + begin + case Get_Identifier (Imp) is + when Std_Names.Name_Get_Resolution_Limit => + return Create_I64_Value + (Ghdl_I64 + (Evaluation.Get_Physical_Value (Std_Package.Time_Base))); + when others => + Error_Msg_Exec ("unsupported foreign function call", Expr); + end case; + return null; + end Execute_Foreign_Function_Call; + + -- BLOCK is the block instance in which the function call appears. + function Execute_Function_Call + (Block: Block_Instance_Acc; Expr: Iir; Imp : Iir) + return Iir_Value_Literal_Acc + is + Inter_Chain : constant Iir := Get_Interface_Declaration_Chain (Imp); + Subprg_Block: Block_Instance_Acc; + Assoc_Chain: Iir; + Res : Iir_Value_Literal_Acc; + begin + Mark (Block.Marker, Instance_Pool.all); + + Subprg_Block := Create_Subprogram_Instance (Block, Imp); + + case Get_Kind (Expr) is + when Iir_Kind_Function_Call => + Adjust_Up_Link_For_Protected_Object (Block, Expr, Subprg_Block); + Assoc_Chain := Get_Parameter_Association_Chain (Expr); + Execute_Association (Block, Subprg_Block, Assoc_Chain); + -- No out/inout interface for functions. + pragma Assert (Subprg_Block.Actuals_Ref = null); + when Iir_Kinds_Dyadic_Operator => + Execute_Dyadic_Association + (Block, Subprg_Block, Expr, Inter_Chain); + when Iir_Kinds_Monadic_Operator => + Execute_Monadic_Association + (Block, Subprg_Block, Expr, Inter_Chain); + when others => + Error_Kind ("execute_subprogram_call_init", Expr); + end case; + + if Get_Foreign_Flag (Imp) then + Res := Execute_Foreign_Function_Call (Subprg_Block, Expr, Imp); + else + Res := Execute_Function_Body (Subprg_Block, Imp); + end if; + + -- Unfortunately, we don't know where the result has been allocated, + -- so copy it before releasing the instance pool. + Res := Unshare (Res, Expr_Pool'Access); + + Release (Block.Marker, Instance_Pool.all); + + return Res; + end Execute_Function_Call; + + -- Slide an array VALUE using bounds from REF_VALUE. Do not modify + -- VALUE if not an array. + procedure Implicit_Array_Conversion (Value : in out Iir_Value_Literal_Acc; + Ref_Value : Iir_Value_Literal_Acc; + Expr : Iir) + is + Res : Iir_Value_Literal_Acc; + begin + if Value.Kind /= Iir_Value_Array then + return; + end if; + Res := Create_Array_Value (Value.Bounds.Nbr_Dims); + Res.Val_Array := Value.Val_Array; + for I in Value.Bounds.D'Range loop + if Value.Bounds.D (I).Length /= Ref_Value.Bounds.D (I).Length then + Error_Msg_Constraint (Expr); + return; + end if; + Res.Bounds.D (I) := Ref_Value.Bounds.D (I); + end loop; + Value := Res; + end Implicit_Array_Conversion; + + procedure Implicit_Array_Conversion (Instance : Block_Instance_Acc; + Value : in out Iir_Value_Literal_Acc; + Ref_Type : Iir; + Expr : Iir) + is + Ref_Value : Iir_Value_Literal_Acc; + begin + -- Do array conversion only if REF_TYPE is a constrained array type + -- definition. + if Value.Kind /= Iir_Value_Array then + return; + end if; + if Get_Constraint_State (Ref_Type) /= Fully_Constrained then + return; + end if; + Ref_Value := Create_Array_Bounds_From_Type (Instance, Ref_Type, True); + for I in Value.Bounds.D'Range loop + if Value.Bounds.D (I).Length /= Ref_Value.Bounds.D (I).Length then + Error_Msg_Constraint (Expr); + return; + end if; + end loop; + Ref_Value.Val_Array.V := Value.Val_Array.V; + Value := Ref_Value; + end Implicit_Array_Conversion; + + procedure Check_Array_Constraints + (Instance: Block_Instance_Acc; + Value: Iir_Value_Literal_Acc; + Def: Iir; + Expr: Iir) + is + Index_List: Iir_List; + Element_Subtype: Iir; + New_Bounds : Iir_Value_Literal_Acc; + begin + -- Nothing to check for unconstrained arrays. + if not Get_Index_Constraint_Flag (Def) then + return; + end if; + + Index_List := Get_Index_Subtype_List (Def); + for I in Value.Bounds.D'Range loop + New_Bounds := Execute_Bounds + (Instance, Get_Nth_Element (Index_List, Natural (I - 1))); + if not Is_Equal (Value.Bounds.D (I), New_Bounds) then + Error_Msg_Constraint (Expr); + return; + end if; + end loop; + + if Boolean'(False) then + Index_List := Get_Index_List (Def); + Element_Subtype := Get_Element_Subtype (Def); + for I in Value.Val_Array.V'Range loop + Check_Constraints + (Instance, Value.Val_Array.V (I), Element_Subtype, Expr); + end loop; + end if; + end Check_Array_Constraints; + + -- Check DEST and SRC are array compatible. + procedure Check_Array_Match + (Instance: Block_Instance_Acc; + Dest: Iir_Value_Literal_Acc; + Src : Iir_Value_Literal_Acc; + Expr: Iir) + is + pragma Unreferenced (Instance); + begin + for I in Dest.Bounds.D'Range loop + if Dest.Bounds.D (I).Length /= Src.Bounds.D (I).Length then + Error_Msg_Constraint (Expr); + exit; + end if; + end loop; + end Check_Array_Match; + pragma Unreferenced (Check_Array_Match); + + procedure Check_Constraints + (Instance: Block_Instance_Acc; + Value: Iir_Value_Literal_Acc; + Def: Iir; + Expr: Iir) + is + Base_Type : constant Iir := Get_Base_Type (Def); + High, Low: Iir_Value_Literal_Acc; + Bound : Iir_Value_Literal_Acc; + begin + case Get_Kind (Def) is + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition => + Bound := Execute_Bounds (Instance, Def); + if Bound.Dir = Iir_To then + High := Bound.Right; + Low := Bound.Left; + else + High := Bound.Left; + Low := Bound.Right; + end if; + case Get_Info (Base_Type).Scalar_Mode is + when Iir_Value_I64 => + if Value.I64 in Low.I64 .. High.I64 then + return; + end if; + when Iir_Value_E32 => + if Value.E32 in Low.E32 .. High.E32 then + return; + end if; + when Iir_Value_F64 => + if Value.F64 in Low.F64 .. High.F64 then + return; + end if; + when Iir_Value_B1 => + if Value.B1 in Low.B1 .. High.B1 then + return; + end if; + when others => + raise Internal_Error; + end case; + when Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Array_Type_Definition => + Check_Array_Constraints (Instance, Value, Def, Expr); + return; + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + declare + El: Iir_Element_Declaration; + List : Iir_List; + begin + List := Get_Elements_Declaration_List (Get_Base_Type (Def)); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Check_Constraints + (Instance, + Value.Val_Record.V (Get_Element_Position (El) + 1), + Get_Type (El), + Expr); + end loop; + end; + return; + when Iir_Kind_Integer_Type_Definition => + return; + when Iir_Kind_Floating_Type_Definition => + return; + when Iir_Kind_Physical_Type_Definition => + return; + when Iir_Kind_Access_Type_Definition + | Iir_Kind_Access_Subtype_Definition => + return; + when Iir_Kind_File_Type_Definition => + return; + when others => + Error_Kind ("check_constraints", Def); + end case; + Error_Msg_Constraint (Expr); + end Check_Constraints; + + function Execute_Resolution_Function + (Block: Block_Instance_Acc; Imp : Iir; Arr : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc + is + Inter : Iir; + Instance : Block_Instance_Acc; + begin + -- Create a frame for this function. + Instance := Create_Subprogram_Instance (Block, Imp); + + Inter := Get_Interface_Declaration_Chain (Imp); + Elaboration.Create_Object (Instance, Inter); + Instance.Objects (Get_Info (Inter).Slot) := Arr; + + return Execute_Function_Body (Instance, Imp); + end Execute_Resolution_Function; + + procedure Execute_Signal_Assignment + (Instance: Block_Instance_Acc; + Stmt: Iir_Signal_Assignment_Statement) + is + Wf : constant Iir_Waveform_Element := Get_Waveform_Chain (Stmt); + Nbr_We : constant Natural := Get_Chain_Length (Wf); + + Transactions : Transaction_Type (Nbr_We); + + We: Iir_Waveform_Element; + Res: Iir_Value_Literal_Acc; + Rdest: Iir_Value_Literal_Acc; + Targ_Type : Iir; + Marker : Mark_Type; + begin + Mark (Marker, Expr_Pool); + + Rdest := Execute_Name (Instance, Get_Target (Stmt), True); + Targ_Type := Get_Type (Get_Target (Stmt)); + + -- Disconnection statement. + if Wf = Null_Iir then + Disconnect_Signal (Rdest); + Release (Marker, Expr_Pool); + return; + end if; + + Transactions.Stmt := Stmt; + + -- LRM93 8.4.1 + -- Evaluation of a waveform consists of the evaluation of each waveform + -- elements in the waveform. + We := Wf; + for I in Transactions.Els'Range loop + declare + Trans : Transaction_El_Type renames Transactions.Els (I); + begin + if Get_Time (We) /= Null_Iir then + Res := Execute_Expression (Instance, Get_Time (We)); + -- LRM93 8.4.1 + -- It is an error if the time expression in a waveform element + -- evaluates to a negative value. + if Res.I64 < 0 then + Error_Msg_Exec ("time value is negative", Get_Time (We)); + end if; + Trans.After := Std_Time (Res.I64); + else + -- LRM93 8.4.1 + -- If the after clause of a waveform element is not present, + -- then an implicit "after 0 ns" is assumed. + Trans.After := 0; + end if; + + -- LRM93 8.4.1 + -- It is an error if the sequence of new transactions is not in + -- ascending order with respect to time. + if I > 1 + and then Trans.After <= Transactions.Els (I - 1).After + then + Error_Msg_Exec + ("sequence not in ascending order with respect to time", We); + end if; + + if Get_Kind (Get_We_Value (We)) = Iir_Kind_Null_Literal then + -- null transaction. + Trans.Value := null; + else + -- LRM93 8.4.1 + -- For the first form of waveform element, the value component + -- of the transaction is determined by the value expression in + -- the waveform element. + Trans.Value := Execute_Expression_With_Type + (Instance, Get_We_Value (We), Targ_Type); + end if; + end; + We := Get_Chain (We); + end loop; + pragma Assert (We = Null_Iir); + + case Get_Delay_Mechanism (Stmt) is + when Iir_Transport_Delay => + Transactions.Reject := 0; + when Iir_Inertial_Delay => + -- LRM93 8.4 + -- or, in the case that a pulse rejection limit is specified, + -- a pulse whose duration is shorter than that limit will not + -- be transmitted. + -- Every inertially delayed signal assignment has a pulse + -- rejection limit. + if Get_Reject_Time_Expression (Stmt) /= Null_Iir then + -- LRM93 8.4 + -- If the delay mechanism specifies inertial delay, and if the + -- reserved word reject followed by a time expression is + -- present, then the time expression specifies the pulse + -- rejection limit. + Res := Execute_Expression + (Instance, Get_Reject_Time_Expression (Stmt)); + -- LRM93 8.4 + -- It is an error if the pulse rejection limit for any + -- inertially delayed signal assignement statement is either + -- negative ... + if Res.I64 < 0 then + Error_Msg_Exec ("reject time negative", Stmt); + end if; + -- LRM93 8.4 + -- ... or greather than the time expression associated with + -- the first waveform element. + Transactions.Reject := Std_Time (Res.I64); + if Transactions.Reject > Transactions.Els (1).After then + Error_Msg_Exec + ("reject time greather than time expression", Stmt); + end if; + else + -- LRM93 8.4 + -- In all other cases, the pulse rejection limit is the time + -- expression associated ith the first waveform element. + Transactions.Reject := Transactions.Els (1).After; + end if; + end case; + + -- FIXME: slice Transactions to remove transactions after end of time. + Assign_Value_To_Signal (Instance, Rdest, Transactions); + + Release (Marker, Expr_Pool); + end Execute_Signal_Assignment; + + procedure Assign_Simple_Value_To_Object + (Instance: Block_Instance_Acc; + Dest: Iir_Value_Literal_Acc; + Dest_Type: Iir; + Value: Iir_Value_Literal_Acc; + Stmt: Iir) + is + begin + if Dest.Kind /= Value.Kind then + raise Internal_Error; -- literal kind mismatch. + end if; + + Check_Constraints (Instance, Value, Dest_Type, Stmt); + + Store (Dest, Value); + end Assign_Simple_Value_To_Object; + + procedure Assign_Array_Value_To_Object + (Instance: Block_Instance_Acc; + Target: Iir_Value_Literal_Acc; + Target_Type: Iir; + Depth: Natural; + Value: Iir_Value_Literal_Acc; + Stmt: Iir) + is + Element_Type: Iir; + begin + if Target.Val_Array.Len /= Value.Val_Array.Len then + -- Dimension mismatch. + raise Program_Error; + end if; + if Depth = Get_Nbr_Elements (Get_Index_List (Target_Type)) then + Element_Type := Get_Element_Subtype (Target_Type); + for I in Target.Val_Array.V'Range loop + Assign_Value_To_Object (Instance, + Target.Val_Array.V (I), + Element_Type, + Value.Val_Array.V (I), + Stmt); + end loop; + else + for I in Target.Val_Array.V'Range loop + Assign_Array_Value_To_Object (Instance, + Target.Val_Array.V (I), + Target_Type, + Depth + 1, + Value.Val_Array.V (I), + Stmt); + end loop; + end if; + end Assign_Array_Value_To_Object; + + procedure Assign_Record_Value_To_Object + (Instance: Block_Instance_Acc; + Target: Iir_Value_Literal_Acc; + Target_Type: Iir; + Value: Iir_Value_Literal_Acc; + Stmt: Iir) + is + Element_Type: Iir; + List : Iir_List; + Element: Iir_Element_Declaration; + Pos : Iir_Index32; + begin + if Target.Val_Record.Len /= Value.Val_Record.Len then + -- Dimension mismatch. + raise Program_Error; + end if; + List := Get_Elements_Declaration_List (Target_Type); + for I in Natural loop + Element := Get_Nth_Element (List, I); + exit when Element = Null_Iir; + Element_Type := Get_Type (Element); + Pos := Get_Element_Position (Element); + Assign_Value_To_Object (Instance, + Target.Val_Record.V (1 + Pos), + Element_Type, + Value.Val_Record.V (1 + Pos), + Stmt); + end loop; + end Assign_Record_Value_To_Object; + + procedure Assign_Value_To_Object + (Instance: Block_Instance_Acc; + Target: Iir_Value_Literal_Acc; + Target_Type: Iir; + Value: Iir_Value_Literal_Acc; + Stmt: Iir) + is + begin + case Target.Kind is + when Iir_Value_Array => + Assign_Array_Value_To_Object + (Instance, Target, Target_Type, 1, Value, Stmt); + when Iir_Value_Record => + Assign_Record_Value_To_Object + (Instance, Target, Target_Type, Value, Stmt); + when Iir_Value_Scalars + | Iir_Value_Access => + Assign_Simple_Value_To_Object + (Instance, Target, Target_Type, Value, Stmt); + when Iir_Value_File + | Iir_Value_Signal + | Iir_Value_Protected + | Iir_Value_Range + | Iir_Value_Quantity + | Iir_Value_Terminal => + raise Internal_Error; + end case; + end Assign_Value_To_Object; + + -- Display a message when an assertion has failed. + -- REPORT is the value (string) to display, or null to use default message. + -- SEVERITY is the severity or null to use default (error). + -- STMT is used to display location. + procedure Execute_Failed_Assertion (Report : String; + Severity : Natural; + Stmt: Iir) is + begin + -- LRM93 8.2 + -- The error message consists of at least: + + -- 4: name of the design unit containing the assertion. + Disp_Iir_Location (Stmt); + + -- 1: an indication that this message is from an assertion. + Put (Standard_Error, "(assertion "); + + -- 2: the value of the severity level. + case Severity is + when 0 => + Put (Standard_Error, "note"); + when 1 => + Put (Standard_Error, "warning"); + when 2 => + Put (Standard_Error, "error"); + when 3 => + Put (Standard_Error, "failure"); + when others => + Error_Internal (Null_Iir, "execute_failed_assertion"); + end case; + if Disp_Time_Before_Values then + Put (Standard_Error, " at "); + Grt.Astdio.Put_Time (Grt.Stdio.stderr, Current_Time); + end if; + Put (Standard_Error, "): "); + + -- 3: the value of the message string. + Put_Line (Standard_Error, Report); + + -- Stop execution if the severity is too high. + if Severity >= Grt.Options.Severity_Level then + Debug (Reason_Assert); + Grt.Errors.Fatal_Error; + end if; + end Execute_Failed_Assertion; + + procedure Execute_Failed_Assertion (Report : Iir_Value_Literal_Acc; + Severity : Natural; + Stmt: Iir) is + begin + if Report /= null then + declare + Msg : String (1 .. Natural (Report.Val_Array.Len)); + begin + for I in Report.Val_Array.V'Range loop + Msg (Positive (I)) := + Character'Val (Report.Val_Array.V (I).E32); + end loop; + Execute_Failed_Assertion (Msg, Severity, Stmt); + end; + else + -- The default value for the message string is: + -- "Assertion violation.". + -- Does the message string include quotes ? + Execute_Failed_Assertion ("Assertion violation.", Severity, Stmt); + end if; + end Execute_Failed_Assertion; + + procedure Execute_Report_Statement + (Instance: Block_Instance_Acc; Stmt: Iir; Default_Severity : Natural) + is + Expr: Iir; + Report, Severity_Lit: Iir_Value_Literal_Acc; + Severity : Natural; + Marker : Mark_Type; + begin + Mark (Marker, Expr_Pool); + Expr := Get_Report_Expression (Stmt); + if Expr /= Null_Iir then + Report := Execute_Expression (Instance, Expr); + else + Report := null; + end if; + Expr := Get_Severity_Expression (Stmt); + if Expr /= Null_Iir then + Severity_Lit := Execute_Expression (Instance, Expr); + Severity := Natural'Val (Severity_Lit.E32); + else + Severity := Default_Severity; + end if; + Execute_Failed_Assertion (Report, Severity, Stmt); + Release (Marker, Expr_Pool); + end Execute_Report_Statement; + + function Is_In_Choice + (Instance: Block_Instance_Acc; + Choice: Iir; + Expr: Iir_Value_Literal_Acc) + return Boolean + is + Res : Boolean; + begin + case Get_Kind (Choice) is + when Iir_Kind_Choice_By_Others => + return True; + when Iir_Kind_Choice_By_Expression => + declare + Expr1: Iir_Value_Literal_Acc; + begin + Expr1 := Execute_Expression + (Instance, Get_Choice_Expression (Choice)); + Res := Is_Equal (Expr, Expr1); + return Res; + end; + when Iir_Kind_Choice_By_Range => + declare + A_Range : Iir_Value_Literal_Acc; + begin + A_Range := Execute_Bounds + (Instance, Get_Choice_Range (Choice)); + Res := Is_In_Range (Expr, A_Range); + end; + return Res; + when others => + Error_Kind ("is_in_choice", Choice); + end case; + end Is_In_Choice; + + -- Return TRUE iff VAL is in the range defined by BOUNDS. + function Is_In_Range (Val : Iir_Value_Literal_Acc; + Bounds : Iir_Value_Literal_Acc) + return Boolean + is + Max, Min : Iir_Value_Literal_Acc; + begin + case Bounds.Dir is + when Iir_To => + Min := Bounds.Left; + Max := Bounds.Right; + when Iir_Downto => + Min := Bounds.Right; + Max := Bounds.Left; + end case; + + case Val.Kind is + when Iir_Value_E32 => + return Val.E32 >= Min.E32 and Val.E32 <= Max.E32; + when Iir_Value_B1 => + return Val.B1 >= Min.B1 and Val.B1 <= Max.B1; + when Iir_Value_I64 => + return Val.I64 >= Min.I64 and Val.I64 <= Max.I64; + when others => + raise Internal_Error; + return False; + end case; + end Is_In_Range; + + -- Increment or decrement VAL according to BOUNDS.DIR. + -- FIXME: use increment ? + procedure Update_Loop_Index (Val : Iir_Value_Literal_Acc; + Bounds : Iir_Value_Literal_Acc) + is + begin + case Val.Kind is + when Iir_Value_E32 => + case Bounds.Dir is + when Iir_To => + Val.E32 := Val.E32 + 1; + when Iir_Downto => + Val.E32 := Val.E32 - 1; + end case; + when Iir_Value_B1 => + case Bounds.Dir is + when Iir_To => + Val.B1 := True; + when Iir_Downto => + Val.B1 := False; + end case; + when Iir_Value_I64 => + case Bounds.Dir is + when Iir_To => + Val.I64 := Val.I64 + 1; + when Iir_Downto => + Val.I64 := Val.I64 - 1; + end case; + when others => + raise Internal_Error; + end case; + end Update_Loop_Index; + + procedure Finalize_For_Loop_Statement (Instance : Block_Instance_Acc; + Stmt : Iir) + is + begin + Destroy_Iterator_Declaration + (Instance, Get_Parameter_Specification (Stmt)); + end Finalize_For_Loop_Statement; + + procedure Finalize_Loop_Statement (Instance : Block_Instance_Acc; + Stmt : Iir) + is + begin + if Get_Kind (Stmt) = Iir_Kind_For_Loop_Statement then + Finalize_For_Loop_Statement (Instance, Stmt); + end if; + end Finalize_Loop_Statement; + + procedure Execute_For_Loop_Statement (Proc : Process_State_Acc) + is + Instance : constant Block_Instance_Acc := Proc.Instance; + Stmt : constant Iir_For_Loop_Statement := Instance.Stmt; + Iterator : constant Iir := Get_Parameter_Specification (Stmt); + Bounds : Iir_Value_Literal_Acc; + Index : Iir_Value_Literal_Acc; + Stmt_Chain : Iir; + Is_Nul : Boolean; + Marker : Mark_Type; + begin + -- Elaborate the iterator (and its type). + Elaborate_Declaration (Instance, Iterator); + + -- Extract bounds. + Mark (Marker, Expr_Pool); + Bounds := Execute_Bounds (Instance, Get_Type (Iterator)); + Index := Instance.Objects (Get_Info (Iterator).Slot); + Store (Index, Bounds.Left); + Is_Nul := Is_Nul_Range (Bounds); + Release (Marker, Expr_Pool); + + if Is_Nul then + -- Loop is complete. + Finalize_For_Loop_Statement (Instance, Stmt); + Update_Next_Statement (Proc); + else + Stmt_Chain := Get_Sequential_Statement_Chain (Stmt); + if Stmt_Chain = Null_Iir then + -- Nothing to do for an empty loop. + Finalize_For_Loop_Statement (Instance, Stmt); + Update_Next_Statement (Proc); + else + Instance.Stmt := Stmt_Chain; + end if; + end if; + end Execute_For_Loop_Statement; + + -- This function is called when there is no more statements to execute + -- in the statement list of a for_loop. Returns FALSE in case of end of + -- loop. + function Finish_For_Loop_Statement (Instance : Block_Instance_Acc) + return Boolean + is + Iterator : constant Iir := Get_Parameter_Specification (Instance.Stmt); + Bounds : Iir_Value_Literal_Acc; + Index : Iir_Value_Literal_Acc; + Marker : Mark_Type; + begin + -- FIXME: avoid allocation. + Mark (Marker, Expr_Pool); + Bounds := Execute_Bounds (Instance, Get_Type (Iterator)); + Index := Instance.Objects (Get_Info (Iterator).Slot); + + if Is_Equal (Index, Bounds.Right) then + -- Loop is complete. + Release (Marker, Expr_Pool); + Finalize_For_Loop_Statement (Instance, Instance.Stmt); + return False; + else + -- Update the loop index. + Update_Loop_Index (Index, Bounds); + + Release (Marker, Expr_Pool); + + -- start the loop again. + Instance.Stmt := Get_Sequential_Statement_Chain (Instance.Stmt); + return True; + end if; + end Finish_For_Loop_Statement; + + -- Evaluate boolean condition COND. If COND is Null_Iir, returns true. + function Execute_Condition (Instance : Block_Instance_Acc; + Cond : Iir) return Boolean + is + V : Iir_Value_Literal_Acc; + Res : Boolean; + Marker : Mark_Type; + begin + if Cond = Null_Iir then + return True; + end if; + + Mark (Marker, Expr_Pool); + V := Execute_Expression (Instance, Cond); + Res := V.B1 = True; + Release (Marker, Expr_Pool); + return Res; + end Execute_Condition; + + -- Start a while loop statement, or return FALSE if the loop is not + -- executed. + procedure Execute_While_Loop_Statement (Proc : Process_State_Acc) + is + Instance: constant Block_Instance_Acc := Proc.Instance; + Stmt : constant Iir := Instance.Stmt; + Cond : Boolean; + begin + Cond := Execute_Condition (Instance, Get_Condition (Stmt)); + if Cond then + Init_Sequential_Statements (Proc, Stmt); + else + Update_Next_Statement (Proc); + end if; + end Execute_While_Loop_Statement; + + -- This function is called when there is no more statements to execute + -- in the statement list of a while loop. Returns FALSE iff loop is + -- completed. + function Finish_While_Loop_Statement (Instance : Block_Instance_Acc) + return Boolean + is + Cond : Boolean; + begin + Cond := Execute_Condition (Instance, Get_Condition (Instance.Stmt)); + + if Cond then + -- start the loop again. + Instance.Stmt := Get_Sequential_Statement_Chain (Instance.Stmt); + return True; + else + -- Loop is complete. + return False; + end if; + end Finish_While_Loop_Statement; + + -- Return TRUE if the loop must be executed again + function Finish_Loop_Statement (Instance : Block_Instance_Acc; + Stmt : Iir) return Boolean is + begin + Instance.Stmt := Stmt; + case Get_Kind (Stmt) is + when Iir_Kind_While_Loop_Statement => + return Finish_While_Loop_Statement (Instance); + when Iir_Kind_For_Loop_Statement => + return Finish_For_Loop_Statement (Instance); + when others => + Error_Kind ("finish_loop_statement", Stmt); + end case; + end Finish_Loop_Statement; + + -- Return FALSE if the next statement should be executed (possibly + -- updated). + procedure Execute_Exit_Next_Statement (Proc : Process_State_Acc; + Is_Exit : Boolean) + is + Instance : constant Block_Instance_Acc := Proc.Instance; + Stmt : constant Iir := Instance.Stmt; + Label : constant Iir := Get_Named_Entity (Get_Loop_Label (Stmt)); + Cond : Boolean; + Parent : Iir; + begin + Cond := Execute_Condition (Instance, Get_Condition (Stmt)); + if not Cond then + Update_Next_Statement (Proc); + return; + end if; + + Parent := Stmt; + loop + Parent := Get_Parent (Parent); + case Get_Kind (Parent) is + when Iir_Kind_For_Loop_Statement + | Iir_Kind_While_Loop_Statement => + if Label = Null_Iir or else Label = Parent then + -- Target is this statement. + if Is_Exit then + Finalize_Loop_Statement (Instance, Parent); + Instance.Stmt := Parent; + Update_Next_Statement (Proc); + elsif not Finish_Loop_Statement (Instance, Parent) then + Update_Next_Statement (Proc); + else + Init_Sequential_Statements (Proc, Parent); + end if; + return; + else + Finalize_Loop_Statement (Instance, Parent); + end if; + when others => + null; + end case; + end loop; + end Execute_Exit_Next_Statement; + + procedure Execute_Case_Statement (Proc : Process_State_Acc) + is + Instance : constant Block_Instance_Acc := Proc.Instance; + Stmt : constant Iir := Instance.Stmt; + Value: Iir_Value_Literal_Acc; + Assoc: Iir; + Stmt_Chain : Iir; + Marker : Mark_Type; + begin + Mark (Marker, Expr_Pool); + + Value := Execute_Expression (Instance, Get_Expression (Stmt)); + Assoc := Get_Case_Statement_Alternative_Chain (Stmt); + + while Assoc /= Null_Iir loop + if not Get_Same_Alternative_Flag (Assoc) then + Stmt_Chain := Get_Associated_Chain (Assoc); + end if; + + if Is_In_Choice (Instance, Assoc, Value) then + if Stmt_Chain = Null_Iir then + Update_Next_Statement (Proc); + else + Instance.Stmt := Stmt_Chain; + end if; + Release (Marker, Expr_Pool); + return; + end if; + + Assoc := Get_Chain (Assoc); + end loop; + -- FIXME: infinite loop??? + Error_Msg_Exec ("no choice for expression", Stmt); + raise Internal_Error; + end Execute_Case_Statement; + + procedure Execute_Call_Statement (Proc : Process_State_Acc) + is + Instance : constant Block_Instance_Acc := Proc.Instance; + Stmt : constant Iir := Instance.Stmt; + Call : constant Iir := Get_Procedure_Call (Stmt); + Imp : constant Iir := Get_Named_Entity (Get_Implementation (Call)); + Subprg_Instance : Block_Instance_Acc; + Assoc_Chain: Iir; + Subprg_Body : Iir; + begin + if Get_Kind (Imp) = Iir_Kind_Implicit_Procedure_Declaration then + Execute_Implicit_Procedure (Instance, Call); + Update_Next_Statement (Proc); + elsif Get_Foreign_Flag (Imp) then + Execute_Foreign_Procedure (Instance, Call); + Update_Next_Statement (Proc); + else + Mark (Instance.Marker, Instance_Pool.all); + Subprg_Instance := Create_Subprogram_Instance (Instance, Imp); + Adjust_Up_Link_For_Protected_Object + (Instance, Call, Subprg_Instance); + Assoc_Chain := Get_Parameter_Association_Chain (Call); + Execute_Association (Instance, Subprg_Instance, Assoc_Chain); + + Current_Process.Instance := Subprg_Instance; + Subprg_Body := Get_Subprogram_Body (Imp); + Elaborate_Declarative_Part + (Subprg_Instance, Get_Declaration_Chain (Subprg_Body)); + + Init_Sequential_Statements (Proc, Subprg_Body); + end if; + end Execute_Call_Statement; + + procedure Finish_Procedure_Frame (Proc : Process_State_Acc) + is + Old_Instance : constant Block_Instance_Acc := Proc.Instance; + begin + Execute_Back_Association (Old_Instance); + Proc.Instance := Old_Instance.Parent; + Execute_Subprogram_Call_Final (Old_Instance); + Release (Proc.Instance.Marker, Instance_Pool.all); + end Finish_Procedure_Frame; + + procedure Execute_If_Statement + (Proc : Process_State_Acc; Stmt: Iir_Wait_Statement) + is + Clause: Iir; + Cond: Boolean; + begin + Clause := Stmt; + loop + Cond := Execute_Condition (Proc.Instance, Get_Condition (Clause)); + if Cond then + Init_Sequential_Statements (Proc, Clause); + return; + end if; + Clause := Get_Else_Clause (Clause); + exit when Clause = Null_Iir; + end loop; + Update_Next_Statement (Proc); + end Execute_If_Statement; + + procedure Execute_Variable_Assignment + (Proc : Process_State_Acc; Stmt : Iir) + is + Instance : constant Block_Instance_Acc := Proc.Instance; + Target : constant Iir := Get_Target (Stmt); + Target_Type : constant Iir := Get_Type (Target); + Expr : constant Iir := Get_Expression (Stmt); + Expr_Type : constant Iir := Get_Type (Expr); + Target_Val: Iir_Value_Literal_Acc; + Res : Iir_Value_Literal_Acc; + Marker : Mark_Type; + begin + Mark (Marker, Expr_Pool); + Target_Val := Execute_Expression (Instance, Target); + + -- If the type of the target is not static and the value is + -- an aggregate, then the aggregate may be contrained by the + -- target. + if Get_Kind (Expr) = Iir_Kind_Aggregate + and then Get_Type_Staticness (Expr_Type) < Locally + and then Get_Kind (Expr_Type) + in Iir_Kinds_Array_Type_Definition + then + Res := Copy_Array_Bound (Target_Val); + Fill_Array_Aggregate (Instance, Expr, Res); + else + Res := Execute_Expression (Instance, Expr); + end if; + if Get_Kind (Target_Type) in Iir_Kinds_Array_Type_Definition then + -- Note: target_type may be dynamic (slice case), so + -- check_constraints is not called. + Implicit_Array_Conversion (Res, Target_Val, Stmt); + else + Check_Constraints (Instance, Res, Target_Type, Stmt); + end if; + + -- Note: we need to unshare before copying to avoid + -- overwrites (in assignments like: v (1 to 4) := v (3 to 6)). + -- FIXME: improve that handling (detect overlaps before). + Store (Target_Val, Unshare (Res, Expr_Pool'Access)); + + Release (Marker, Expr_Pool); + end Execute_Variable_Assignment; + + function Execute_Return_Statement (Proc : Process_State_Acc) + return Boolean + is + Res : Iir_Value_Literal_Acc; + Instance : constant Block_Instance_Acc := Proc.Instance; + Stmt : constant Iir := Instance.Stmt; + Expr : constant Iir := Get_Expression (Stmt); + begin + if Expr /= Null_Iir then + Res := Execute_Expression (Instance, Expr); + Implicit_Array_Conversion (Instance, Res, Get_Type (Stmt), Stmt); + Check_Constraints (Instance, Res, Get_Type (Stmt), Stmt); + Instance.Result := Res; + end if; + + case Get_Kind (Instance.Label) is + when Iir_Kind_Procedure_Declaration => + Finish_Procedure_Frame (Proc); + Update_Next_Statement (Proc); + return False; + when Iir_Kind_Function_Declaration => + return True; + when others => + raise Internal_Error; + end case; + end Execute_Return_Statement; + + procedure Finish_Sequential_Statements + (Proc : Process_State_Acc; Complex_Stmt : Iir) + is + Instance : Block_Instance_Acc := Proc.Instance; + Stmt : Iir; + begin + Stmt := Complex_Stmt; + loop + Instance.Stmt := Stmt; + case Get_Kind (Stmt) is + when Iir_Kind_For_Loop_Statement => + if Finish_For_Loop_Statement (Instance) then + return; + end if; + when Iir_Kind_While_Loop_Statement => + if Finish_While_Loop_Statement (Instance) then + return; + end if; + when Iir_Kind_Case_Statement + | Iir_Kind_If_Statement => + null; + when Iir_Kind_Sensitized_Process_Statement => + Instance.Stmt := Null_Iir; + return; + when Iir_Kind_Process_Statement => + -- Start again. + Instance.Stmt := Get_Sequential_Statement_Chain (Stmt); + return; + when Iir_Kind_Procedure_Body => + Finish_Procedure_Frame (Proc); + Instance := Proc.Instance; + when Iir_Kind_Function_Body => + Error_Msg_Exec ("missing return statement in function", Stmt); + when others => + Error_Kind ("execute_next_statement", Stmt); + end case; + Stmt := Get_Chain (Instance.Stmt); + if Stmt /= Null_Iir then + Instance.Stmt := Stmt; + return; + end if; + Stmt := Get_Parent (Instance.Stmt); + end loop; + end Finish_Sequential_Statements; + + procedure Init_Sequential_Statements + (Proc : Process_State_Acc; Complex_Stmt : Iir) + is + Stmt : Iir; + begin + Stmt := Get_Sequential_Statement_Chain (Complex_Stmt); + if Stmt /= Null_Iir then + Proc.Instance.Stmt := Stmt; + else + Finish_Sequential_Statements (Proc, Complex_Stmt); + end if; + end Init_Sequential_Statements; + + procedure Update_Next_Statement (Proc : Process_State_Acc) + is + Instance : constant Block_Instance_Acc := Proc.Instance; + Stmt : Iir; + begin + Stmt := Get_Chain (Instance.Stmt); + if Stmt /= Null_Iir then + Instance.Stmt := Stmt; + return; + end if; + Finish_Sequential_Statements (Proc, Get_Parent (Instance.Stmt)); + end Update_Next_Statement; + + procedure Execute_Sequential_Statements (Proc : Process_State_Acc) + is + Instance : Block_Instance_Acc; + Stmt: Iir; + begin + loop + Instance := Proc.Instance; + Stmt := Instance.Stmt; + + -- End of process or subprogram. + exit when Stmt = Null_Iir; + + if Trace_Statements then + declare + Name : Name_Id; + Line : Natural; + Col : Natural; + begin + Files_Map.Location_To_Position + (Get_Location (Stmt), Name, Line, Col); + Put_Line ("Execute statement at " + & Name_Table.Image (Name) + & Natural'Image (Line)); + end; + end if; + + if Flag_Need_Debug then + Debug (Reason_Break); + end if; + + -- execute statement STMT. + case Get_Kind (Stmt) is + when Iir_Kind_Null_Statement => + Update_Next_Statement (Proc); + + when Iir_Kind_If_Statement => + Execute_If_Statement (Proc, Stmt); + + when Iir_Kind_Signal_Assignment_Statement => + Execute_Signal_Assignment (Instance, Stmt); + Update_Next_Statement (Proc); + + when Iir_Kind_Assertion_Statement => + declare + Res : Boolean; + begin + Res := Execute_Condition + (Instance, Get_Assertion_Condition (Stmt)); + if not Res then + Execute_Report_Statement (Instance, Stmt, 2); + end if; + end; + Update_Next_Statement (Proc); + + when Iir_Kind_Report_Statement => + Execute_Report_Statement (Instance, Stmt, 0); + Update_Next_Statement (Proc); + + when Iir_Kind_Variable_Assignment_Statement => + Execute_Variable_Assignment (Proc, Stmt); + Update_Next_Statement (Proc); + + when Iir_Kind_Return_Statement => + if Execute_Return_Statement (Proc) then + return; + end if; + + when Iir_Kind_For_Loop_Statement => + Execute_For_Loop_Statement (Proc); + + when Iir_Kind_While_Loop_Statement => + Execute_While_Loop_Statement (Proc); + + when Iir_Kind_Case_Statement => + Execute_Case_Statement (Proc); + + when Iir_Kind_Wait_Statement => + if Execute_Wait_Statement (Instance, Stmt) then + return; + end if; + Update_Next_Statement (Proc); + + when Iir_Kind_Procedure_Call_Statement => + Execute_Call_Statement (Proc); + + when Iir_Kind_Exit_Statement => + Execute_Exit_Next_Statement (Proc, True); + when Iir_Kind_Next_Statement => + Execute_Exit_Next_Statement (Proc, False); + + when others => + Error_Kind ("execute_sequential_statements", Stmt); + end case; + end loop; + end Execute_Sequential_Statements; +end Execution; diff --git a/src/simulate/execution.ads b/src/simulate/execution.ads new file mode 100644 index 000000000..faed1111d --- /dev/null +++ b/src/simulate/execution.ads @@ -0,0 +1,185 @@ +-- Interpreted simulation +-- Copyright (C) 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 GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Types; use Types; +with Iirs; use Iirs; +with Iir_Values; use Iir_Values; +with Elaboration; use Elaboration; +with Areapools; use Areapools; + +package Execution is + Trace_Statements : Boolean := False; + + -- If true, disp current time in assert message. + Disp_Time_Before_Values: Boolean := False; + + Current_Component : Block_Instance_Acc := null; + + -- State associed with each process. + type Process_State_Type is record + -- The process instance. + Top_Instance: Block_Instance_Acc := null; + Proc: Iir := Null_Iir; + + -- Memory pool to allocate objects from. + Pool : aliased Areapool; + + -- The stack of the process. + Instance : Block_Instance_Acc := null; + end record; + type Process_State_Acc is access all Process_State_Type; + + Simulation_Finished : exception; + + -- Current process being executed. This is only for the debugger. + Current_Process : Process_State_Acc; + + -- Pseudo process used for resolution functions, ... + No_Process : Process_State_Acc := new Process_State_Type; + -- Execute a list of sequential statements. + -- Return when there is no more statements to execute. + procedure Execute_Sequential_Statements (Proc : Process_State_Acc); + + -- Evaluate an expression. + function Execute_Expression (Block: Block_Instance_Acc; Expr: Iir) + return Iir_Value_Literal_Acc; + + -- Evaluate boolean condition COND. If COND is Null_Iir, returns true. + function Execute_Condition (Instance : Block_Instance_Acc; + Cond : Iir) return Boolean; + + -- Execute a name. Return the value if Ref is False, or the reference + -- (for a signal, a quantity or a terminal) if Ref is True. + function Execute_Name (Block: Block_Instance_Acc; + Expr: Iir; + Ref : Boolean := False) + return Iir_Value_Literal_Acc; + + procedure Execute_Name_With_Base (Block: Block_Instance_Acc; + Expr: Iir; + Base : Iir_Value_Literal_Acc; + Res : out Iir_Value_Literal_Acc; + Is_Sig : out Boolean); + + -- Return the initial value (default value) of signal name EXPR. To be + -- used only during (non-dynamic) elaboration. + function Execute_Signal_Init_Value (Block : Block_Instance_Acc; Expr : Iir) + return Iir_Value_Literal_Acc; + + function Execute_Expression_With_Type + (Block: Block_Instance_Acc; + Expr: Iir; + Expr_Type : Iir) + return Iir_Value_Literal_Acc; + + function Execute_Resolution_Function + (Block: Block_Instance_Acc; Imp : Iir; Arr : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc; + + function Execute_Assoc_Conversion + (Block : Block_Instance_Acc; Conv : Iir; Val : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc; + + -- Sub function common for left/right/length/low/high attributes. + -- Return bounds of PREFIX. + function Execute_Bounds (Block: Block_Instance_Acc; Prefix: Iir) + return Iir_Value_Literal_Acc; + + -- Compute the offset for INDEX into a range BOUNDS. + -- EXPR is only used in case of error. + function Get_Index_Offset + (Index: Iir_Value_Literal_Acc; + Bounds: Iir_Value_Literal_Acc; + Expr: Iir) + return Iir_Index32; + + function Execute_Low_Limit (Bounds : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc; + + function Get_Instance_For_Slot (Instance: Block_Instance_Acc; Decl: Iir) + return Block_Instance_Acc; + + -- Store VALUE to TARGET. + -- Note: VALUE is not freed. + procedure Assign_Value_To_Object + (Instance: Block_Instance_Acc; + Target: Iir_Value_Literal_Acc; + Target_Type: Iir; + Value: Iir_Value_Literal_Acc; + Stmt: Iir); + + -- Check VALUE follows the constraints of DEF. + -- INSTANCE,DEF is the definition of a subtype. + -- EXPR is just used in case of error to display the location + -- If there is no location, EXPR can be null. + -- Implicitly convert VALUE (array cases). + -- Return in case of success. + -- Raise errorout.execution_constraint_error in case of failure. + procedure Check_Constraints + (Instance: Block_Instance_Acc; + Value: Iir_Value_Literal_Acc; + Def: Iir; Expr: Iir); + + -- If VALUE is not an array, then this is a no-op. + -- If VALUE is an array, then bounds are checked and converted. INSTANCE + -- is the instance corresponding to REF_TYPE. + -- EXPR is used in case of error. + procedure Implicit_Array_Conversion (Value : in out Iir_Value_Literal_Acc; + Ref_Value : Iir_Value_Literal_Acc; + Expr : Iir); + procedure Implicit_Array_Conversion (Instance : Block_Instance_Acc; + Value : in out Iir_Value_Literal_Acc; + Ref_Type : Iir; + Expr : Iir); + + -- Create an iir_value_literal of kind iir_value_array and of life LIFE. + -- Allocate the array of bounds, and fill it from A_TYPE. + -- Allocate the array of values. + function Create_Array_Bounds_From_Type + (Block : Block_Instance_Acc; + A_Type : Iir; + Create_Val_Array : Boolean) + return Iir_Value_Literal_Acc; + + -- Create a range from LEN for scalar type ATYPE. + function Create_Bounds_From_Length (Block : Block_Instance_Acc; + Atype : Iir; + Len : Iir_Index32) + return Iir_Value_Literal_Acc; + + -- Return TRUE iff VAL is in the range defined by BOUNDS. + function Is_In_Range (Val : Iir_Value_Literal_Acc; + Bounds : Iir_Value_Literal_Acc) + return Boolean; + + -- Increment or decrement VAL according to BOUNDS.DIR. + procedure Update_Loop_Index (Val : Iir_Value_Literal_Acc; + Bounds : Iir_Value_Literal_Acc); + + -- Create a block instance for subprogram IMP. + function Create_Subprogram_Instance (Instance : Block_Instance_Acc; + Imp : Iir) + return Block_Instance_Acc; + + function Execute_Function_Body (Instance : Block_Instance_Acc; Func : Iir) + return Iir_Value_Literal_Acc; + + function Execute_Image_Attribute (Val : Iir_Value_Literal_Acc; + Expr_Type : Iir) + return String; +end Execution; diff --git a/src/simulate/file_operation.adb b/src/simulate/file_operation.adb new file mode 100644 index 000000000..33700fd6c --- /dev/null +++ b/src/simulate/file_operation.adb @@ -0,0 +1,341 @@ +-- File operations for interpreter +-- Copyright (C) 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 GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Types; use Types; +with Annotations; use Annotations; +with Execution; use Execution; +with Debugger; use Debugger; +with Grt.Types; use Grt.Types; +with Grt_Interface; use Grt_Interface; + +package body File_Operation is + -- Open a file. + -- See LRM93 3.4.1 for definition of arguments. + -- IS_TEXT is true if the file format is text. + -- The purpose of the IS_TEXT is to allow a text implementation of file + -- type TEXT, defined in std.textio. + procedure File_Open (Status : out Ghdl_I32; + File : Iir_Value_Literal_Acc; + External_Name : Iir_Value_Literal_Acc; + Mode : Ghdl_I32; + Is_Text : Boolean; + Return_Status : Boolean) + is + Name_Len : constant Ghdl_Index_Type := + Ghdl_Index_Type (External_Name.Bounds.D (1).Length); + Name_Str : aliased Std_String_Uncons (1 .. Name_Len); + Name_Bnd : aliased Std_String_Bound := Build_Bound (External_Name); + Name : aliased Std_String := (To_Std_String_Basep (Name_Str'Address), + To_Std_String_Boundp (Name_Bnd'Address)); + begin + -- Convert the string to an Ada string. + for I in External_Name.Val_Array.V'Range loop + Name_Str (Name_Str'First + Ghdl_Index_Type (I - 1)) := + Character'Val (External_Name.Val_Array.V (I).E32); + end loop; + + if Is_Text then + if Return_Status then + Status := Ghdl_Text_File_Open_Status + (File.File, Mode, Name'Unrestricted_Access); + else + Ghdl_Text_File_Open (File.File, Mode, Name'Unrestricted_Access); + Status := Open_Ok; + end if; + else + if Return_Status then + Status := Ghdl_File_Open_Status + (File.File, Mode, Name'Unrestricted_Access); + else + Ghdl_File_Open (File.File, Mode, Name'Unrestricted_Access); + Status := Open_Ok; + end if; + end if; + end File_Open; + + -- Open a file. + procedure File_Open (File : Iir_Value_Literal_Acc; + Name : Iir_Value_Literal_Acc; + Mode : Iir_Value_Literal_Acc; + File_Decl : Iir; + Stmt : Iir) + is + pragma Unreferenced (Stmt); + Is_Text : constant Boolean := Get_Text_File_Flag (Get_Type (File_Decl)); + File_Mode : constant Ghdl_I32 := Ghdl_I32 (Mode.E32); + Status : Ghdl_I32; + begin + File_Open (Status, File, Name, File_Mode, Is_Text, False); + if Status /= Open_Ok then + raise Program_Error; + end if; + end File_Open; + + procedure File_Open_Status (Status : Iir_Value_Literal_Acc; + File : Iir_Value_Literal_Acc; + Name : Iir_Value_Literal_Acc; + Mode : Iir_Value_Literal_Acc; + File_Decl : Iir; + Stmt : Iir) + is + pragma Unreferenced (Stmt); + Is_Text : constant Boolean := Get_Text_File_Flag (Get_Type (File_Decl)); + File_Mode : constant Ghdl_I32 := Ghdl_I32 (Mode.E32); + R_Status : Ghdl_I32; + begin + File_Open (R_Status, File, Name, File_Mode, Is_Text, True); + Status.E32 := Ghdl_E32 (R_Status); + end File_Open_Status; + + function Elaborate_File_Declaration + (Instance: Block_Instance_Acc; Decl: Iir_File_Declaration) + return Iir_Value_Literal_Acc + is + Def : constant Iir := Get_Type (Decl); + External_Name : Iir; + File_Name: Iir_Value_Literal_Acc; + Is_Text : constant Boolean := Get_Text_File_Flag (Def); + File_Mode : Ghdl_I32; + Res : Iir_Value_Literal_Acc; + Status : Ghdl_I32; + Mode : Iir_Value_Literal_Acc; + begin + if Is_Text then + Res := Create_File_Value (Ghdl_Text_File_Elaborate); + else + declare + Sig : constant String_Acc := Get_Info (Def).File_Signature; + Cstr : Ghdl_C_String; + begin + if Sig = null then + Cstr := null; + else + Cstr := To_Ghdl_C_String (Sig.all'Address); + end if; + Res := Create_File_Value (Ghdl_File_Elaborate (Cstr)); + end; + end if; + + External_Name := Get_File_Logical_Name (Decl); + + -- LRM93 4.3.1.4 + -- If file open information is not included in a given file declaration, + -- then the file declared by the declaration is not opened when the file + -- declaration is elaborated. + if External_Name = Null_Iir then + return Res; + end if; + + File_Name := Execute_Expression (Instance, External_Name); + if Get_File_Open_Kind (Decl) /= Null_Iir then + Mode := Execute_Expression (Instance, Get_File_Open_Kind (Decl)); + File_Mode := Ghdl_I32 (Mode.E32); + else + case Get_Mode (Decl) is + when Iir_In_Mode => + File_Mode := Read_Mode; + when Iir_Out_Mode => + File_Mode := Write_Mode; + when others => + raise Internal_Error; + end case; + end if; + File_Open (Status, Res, File_Name, File_Mode, Is_Text, False); + return Res; + end Elaborate_File_Declaration; + + procedure File_Close_Text (File : Iir_Value_Literal_Acc; Stmt : Iir) is + pragma Unreferenced (Stmt); + begin + Ghdl_Text_File_Close (File.File); + end File_Close_Text; + + procedure File_Close_Binary (File : Iir_Value_Literal_Acc; Stmt : Iir) is + pragma Unreferenced (Stmt); + begin + Ghdl_File_Close (File.File); + end File_Close_Binary; + + procedure File_Destroy_Text (File : Iir_Value_Literal_Acc) is + begin + Ghdl_Text_File_Finalize (File.File); + end File_Destroy_Text; + + procedure File_Destroy_Binary (File : Iir_Value_Literal_Acc) is + begin + Ghdl_File_Finalize (File.File); + end File_Destroy_Binary; + + + procedure Write_Binary (File: Iir_Value_Literal_Acc; + Value: Iir_Value_Literal_Acc) is + begin + case Value.Kind is + when Iir_Value_B1 => + Ghdl_Write_Scalar (File.File, Ghdl_Ptr (Value.B1'Address), 1); + when Iir_Value_I64 => + Ghdl_Write_Scalar (File.File, Ghdl_Ptr (Value.I64'Address), 8); + when Iir_Value_E32 => + Ghdl_Write_Scalar (File.File, Ghdl_Ptr (Value.E32'Address), 4); + when Iir_Value_F64 => + Ghdl_Write_Scalar (File.File, Ghdl_Ptr (Value.F64'Address), 8); + when Iir_Value_Array => + for I in Value.Bounds.D'Range loop + Ghdl_Write_Scalar + (File.File, Ghdl_Ptr (Value.Bounds.D (I).Length'Address), 4); + end loop; + for I in Value.Val_Array.V'Range loop + Write_Binary (File, Value.Val_Array.V (I)); + end loop; + when Iir_Value_Record => + for I in Value.Val_Record.V'Range loop + Write_Binary (File, Value.Val_Record.V (I)); + end loop; + when others => + raise Internal_Error; + end case; + end Write_Binary; + + procedure Write_Text (File: Iir_Value_Literal_Acc; + Value: Iir_Value_Literal_Acc) + is + Val_Len : constant Ghdl_Index_Type := + Ghdl_Index_Type (Value.Bounds.D (1).Length); + Val_Str : aliased Std_String_Uncons (1 .. Val_Len); + Val_Bnd : aliased Std_String_Bound := Build_Bound (Value); + Val : aliased Std_String := (To_Std_String_Basep (Val_Str'Address), + To_Std_String_Boundp (Val_Bnd'Address)); + begin + -- Convert the string to an Ada string. + for I in Value.Val_Array.V'Range loop + Val_Str (Val_Str'First + Ghdl_Index_Type (I - 1)) := + Character'Val (Value.Val_Array.V (I).E32); + end loop; + + Ghdl_Text_Write (File.File, Val'Unrestricted_Access); + end Write_Text; + + function Endfile (File : Iir_Value_Literal_Acc; Stmt : Iir) + return Boolean + is + pragma Unreferenced (Stmt); + begin + return Grt.Files.Ghdl_File_Endfile (File.File); + end Endfile; + + procedure Read_Length_Text (File : Iir_Value_Literal_Acc; + Value : Iir_Value_Literal_Acc; + Length : Iir_Value_Literal_Acc) + is + Val_Len : constant Ghdl_Index_Type := + Ghdl_Index_Type (Value.Bounds.D (1).Length); + Val_Str : aliased Std_String_Uncons (1 .. Val_Len); + Val_Bnd : aliased Std_String_Bound := Build_Bound (Value); + Val : aliased Std_String := (To_Std_String_Basep (Val_Str'Address), + To_Std_String_Boundp (Val_Bnd'Address)); + Len : Std_Integer; + begin + Len := Ghdl_Text_Read_Length (File.File, Val'Unrestricted_Access); + for I in 1 .. Len loop + Value.Val_Array.V (Iir_Index32 (I)).E32 := + Character'Pos (Val_Str (Ghdl_Index_Type (I))); + end loop; + Length.I64 := Ghdl_I64 (Len); + end Read_Length_Text; + + procedure Untruncated_Text_Read (File : Iir_Value_Literal_Acc; + Str : Iir_Value_Literal_Acc; + Length : Iir_Value_Literal_Acc) + is + Res : Ghdl_Untruncated_Text_Read_Result; + Val_Len : constant Ghdl_Index_Type := + Ghdl_Index_Type (Str.Bounds.D (1).Length); + Val_Str : aliased Std_String_Uncons (1 .. Val_Len); + Val_Bnd : aliased Std_String_Bound := Build_Bound (Str); + Val : aliased Std_String := (To_Std_String_Basep (Val_Str'Address), + To_Std_String_Boundp (Val_Bnd'Address)); + begin + Ghdl_Untruncated_Text_Read + (Res'Unrestricted_Access, File.File, Val'Unrestricted_Access); + for I in 1 .. Res.Len loop + Str.Val_Array.V (Iir_Index32 (I)).E32 := + Character'Pos (Val_Str (Ghdl_Index_Type (I))); + end loop; + Length.I64 := Ghdl_I64 (Res.Len); + end Untruncated_Text_Read; + + procedure Read_Binary (File: Iir_Value_Literal_Acc; + Value: Iir_Value_Literal_Acc) + is + begin + case Value.Kind is + when Iir_Value_B1 => + Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Value.B1'Address), 1); + when Iir_Value_I64 => + Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Value.I64'Address), 8); + when Iir_Value_E32 => + Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Value.E32'Address), 4); + when Iir_Value_F64 => + Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Value.F64'Address), 8); + when Iir_Value_Array => + for I in Value.Bounds.D'Range loop + declare + Len : Iir_Index32; + begin + Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Len'Address), 4); + if Len /= Value.Bounds.D (I).Length then + Error_Msg_Constraint (Null_Iir); -- FIXME: loc + end if; + end; + end loop; + for I in Value.Val_Array.V'Range loop + Read_Binary (File, Value.Val_Array.V (I)); + end loop; + when Iir_Value_Record => + for I in Value.Val_Record.V'Range loop + Read_Binary (File, Value.Val_Record.V (I)); + end loop; + when others => + raise Internal_Error; + end case; + end Read_Binary; + + procedure Read_Length_Binary (File : Iir_Value_Literal_Acc; + Value : Iir_Value_Literal_Acc; + Length : Iir_Value_Literal_Acc) + is + Len : Iir_Index32; + begin + Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Len'Address), 4); + for I in 1 .. Len loop + if I <= Value.Bounds.D (1).Length then + Read_Binary (File, Value.Val_Array.V (I)); + else + -- FIXME: for empty arrays ?? + -- Lose_Binary (File, Value.Val_Array (0)); + raise Internal_Error; + end if; + end loop; + Length.I64 := Ghdl_I64 (Len); + end Read_Length_Binary; + + procedure Flush (File : Iir_Value_Literal_Acc) is + begin + Ghdl_File_Flush (File.File); + end Flush; +end File_Operation; diff --git a/src/simulate/file_operation.ads b/src/simulate/file_operation.ads new file mode 100644 index 000000000..b66a06756 --- /dev/null +++ b/src/simulate/file_operation.ads @@ -0,0 +1,81 @@ +-- File operations for interpreter +-- Copyright (C) 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 GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Iirs; use Iirs; +with Iir_Values; use Iir_Values; +with Elaboration; use Elaboration; +with Grt.Files; use Grt.Files; + +package File_Operation is + Null_File : constant Natural := 0; + + -- Open a file. + procedure File_Open (File : Iir_Value_Literal_Acc; + Name : Iir_Value_Literal_Acc; + Mode : Iir_Value_Literal_Acc; + File_Decl : Iir; + Stmt : Iir); + + procedure File_Open_Status (Status : Iir_Value_Literal_Acc; + File : Iir_Value_Literal_Acc; + Name : Iir_Value_Literal_Acc; + Mode : Iir_Value_Literal_Acc; + File_Decl : Iir; + Stmt : Iir); + + -- Close a file. + -- If the file was not open, this has no effects. + procedure File_Close_Text (File : Iir_Value_Literal_Acc; Stmt : Iir); + procedure File_Close_Binary (File : Iir_Value_Literal_Acc; Stmt : Iir); + + procedure File_Destroy_Text (File : Iir_Value_Literal_Acc); + procedure File_Destroy_Binary (File : Iir_Value_Literal_Acc); + + -- Elaborate a file_declaration. + function Elaborate_File_Declaration + (Instance: Block_Instance_Acc; Decl: Iir_File_Declaration) + return Iir_Value_Literal_Acc; + + -- Write VALUE to FILE. + -- STMT is the statement, to display error. + procedure Write_Text (File: Iir_Value_Literal_Acc; + Value: Iir_Value_Literal_Acc); + procedure Write_Binary (File: Iir_Value_Literal_Acc; + Value: Iir_Value_Literal_Acc); + + procedure Read_Binary (File: Iir_Value_Literal_Acc; + Value: Iir_Value_Literal_Acc); + + procedure Read_Length_Text (File : Iir_Value_Literal_Acc; + Value : Iir_Value_Literal_Acc; + Length : Iir_Value_Literal_Acc); + + procedure Read_Length_Binary (File : Iir_Value_Literal_Acc; + Value : Iir_Value_Literal_Acc; + Length : Iir_Value_Literal_Acc); + + procedure Untruncated_Text_Read (File : Iir_Value_Literal_Acc; + Str : Iir_Value_Literal_Acc; + Length : Iir_Value_Literal_Acc); + + procedure Flush (File : Iir_Value_Literal_Acc); + + -- Test end of FILE is reached. + function Endfile (File : Iir_Value_Literal_Acc; Stmt : Iir) + return Boolean; +end File_Operation; diff --git a/src/simulate/grt_interface.adb b/src/simulate/grt_interface.adb new file mode 100644 index 000000000..c4eab58c4 --- /dev/null +++ b/src/simulate/grt_interface.adb @@ -0,0 +1,44 @@ +-- Interpreted simulation +-- Copyright (C) 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 GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Iirs; use Iirs; +with Types; use Types; + +package body Grt_Interface is + To_Dir : constant array (Iir_Direction) of Ghdl_Dir_Type := + (Iir_To => Dir_To, Iir_Downto => Dir_Downto); + + function Build_Bound (Arr : Iir_Value_Literal_Acc) return Std_String_Bound + is + Rng : constant Iir_Value_Literal_Acc := Arr.Bounds.D (1); + begin + return (Dim_1 => (Left => Std_Integer (Rng.Left.I64), + Right => Std_Integer (Rng.Right.I64), + Dir => To_Dir (Rng.Dir), + Length => Ghdl_Index_Type (Rng.Length))); + end Build_Bound; + + procedure Set_Std_String_From_Iir_Value (Str : Std_String; + Val : Iir_Value_Literal_Acc) is + begin + for I in Val.Val_Array.V'Range loop + Str.Base (Ghdl_Index_Type (I - 1)) := + Character'Val (Val.Val_Array.V (I).E32); + end loop; + end Set_Std_String_From_Iir_Value; +end Grt_Interface; diff --git a/src/simulate/grt_interface.ads b/src/simulate/grt_interface.ads new file mode 100644 index 000000000..05f7abb69 --- /dev/null +++ b/src/simulate/grt_interface.ads @@ -0,0 +1,27 @@ +-- Interpreted simulation +-- Copyright (C) 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 GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Grt.Types; use Grt.Types; +with Iir_Values; use Iir_Values; + +package Grt_Interface is + procedure Set_Std_String_From_Iir_Value (Str : Std_String; + Val : Iir_Value_Literal_Acc); + + function Build_Bound (Arr : Iir_Value_Literal_Acc) return Std_String_Bound; +end Grt_Interface; diff --git a/src/simulate/iir_values.adb b/src/simulate/iir_values.adb new file mode 100644 index 000000000..d80f3bf0a --- /dev/null +++ b/src/simulate/iir_values.adb @@ -0,0 +1,1066 @@ +-- Naive values for interpreted simulation +-- Copyright (C) 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 GHDL; 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 Ada.Unchecked_Conversion; +with GNAT.Debug_Utilities; +with Name_Table; +with Debugger; use Debugger; +with Iirs_Utils; use Iirs_Utils; + +package body Iir_Values is + + -- Functions for iir_value_literal + function Is_Equal (Left, Right: Iir_Value_Literal_Acc) return Boolean is + begin + if Left.Kind /= Right.Kind then + raise Internal_Error; + end if; + case Left.Kind is + when Iir_Value_B1 => + return Left.B1 = Right.B1; + when Iir_Value_E32 => + return Left.E32 = Right.E32; + when Iir_Value_I64 => + return Left.I64 = Right.I64; + when Iir_Value_F64 => + return Left.F64 = Right.F64; + when Iir_Value_Access => + return Left.Val_Access = Right.Val_Access; + when Iir_Value_File => + raise Internal_Error; + when Iir_Value_Array => + if Left.Bounds.Nbr_Dims /= Right.Bounds.Nbr_Dims then + raise Internal_Error; + end if; + for I in Left.Bounds.D'Range loop + if Left.Bounds.D (I).Length /= Right.Bounds.D (I).Length then + return False; + end if; + end loop; + for I in Left.Val_Array.V'Range loop + if not Is_Equal (Left.Val_Array.V (I), + Right.Val_Array.V (I)) then + return False; + end if; + end loop; + return True; + when Iir_Value_Record => + if Left.Val_Record.Len /= Right.Val_Record.Len then + raise Constraint_Error; + end if; + for I in Left.Val_Record.V'Range loop + if not Is_Equal (Left.Val_Record.V (I), + Right.Val_Record.V (I)) then + return False; + end if; + end loop; + return True; + when Iir_Value_Range => + if Left.Dir /= Right.Dir then + return False; + end if; + if not Is_Equal (Left.Left, Right.Left) then + return False; + end if; + if not Is_Equal (Left.Right, Right.Right) then + return False; + end if; + return True; + when Iir_Value_Signal + | Iir_Value_Protected + | Iir_Value_Quantity + | Iir_Value_Terminal => + raise Internal_Error; + end case; + end Is_Equal; + + function Compare_Value (Left, Right : Iir_Value_Literal_Acc) + return Order is + begin + if Left.Kind /= Right.Kind then + raise Constraint_Error; + end if; + case Left.Kind is + when Iir_Value_B1 => + if Left.B1 < Right.B1 then + return Less; + elsif Left.B1 = Right.B1 then + return Equal; + else + return Greater; + end if; + when Iir_Value_E32 => + if Left.E32 < Right.E32 then + return Less; + elsif Left.E32 = Right.E32 then + return Equal; + else + return Greater; + end if; + when Iir_Value_I64 => + if Left.I64 < Right.I64 then + return Less; + elsif Left.I64 = Right.I64 then + return Equal; + else + return Greater; + end if; + when Iir_Value_F64 => + if Left.F64 < Right.F64 then + return Less; + elsif Left.F64 = Right.F64 then + return Equal; + elsif Left.F64 > Right.F64 then + return Greater; + else + raise Constraint_Error; + end if; + when Iir_Value_Array => + -- LRM93 §7.2.2 + -- For discrete array types, the relation < (less than) is defined + -- such as the left operand is less than the right operand if + -- and only if: + -- * the left operand is a null array and the right operand is + -- a non-null array; otherwise + -- * both operands are non-null arrays, and one of the following + -- conditions is satisfied: + -- - the leftmost element of the left operand is less than + -- that of the right; or + -- - the leftmost element of the left operand is equal to + -- that of the right, and the tail of the left operand is + -- less than that of the right (the tail consists of the + -- remaining elements to the rights of the leftmost element + -- and can be null) + -- The relation <= (less than or equal) for discrete array types + -- is defined to be the inclusive disjunction of the results of + -- the < and = operators for the same two operands. + -- The relation > (greater than) and >= (greater than of equal) + -- are defined to be the complements of the <= and < operators + -- respectively for the same two operands. + if Left.Bounds.Nbr_Dims /= 1 or Right.Bounds.Nbr_Dims /= 1 then + raise Internal_Error; + end if; + for I in 1 .. Iir_Index32'Min (Left.Bounds.D (1).Length, + Right.Bounds.D (1).Length) + loop + case Compare_Value (Left.Val_Array.V (I), + Right.Val_Array.V (I)) is + when Less => + return Less; + when Greater => + return Greater; + when Equal => + null; + end case; + end loop; + if Left.Bounds.D (1).Length < Right.Bounds.D (1).Length then + return Less; + elsif Left.Bounds.D (1).Length = Right.Bounds.D (1).Length then + return Equal; + else + return Greater; + end if; + when Iir_Value_Signal + | Iir_Value_Access + | Iir_Value_Range + | Iir_Value_Record + | Iir_Value_File + | Iir_Value_Protected + | Iir_Value_Quantity + | Iir_Value_Terminal => + raise Internal_Error; + end case; + end Compare_Value; + + function Is_Nul_Range (Arange : Iir_Value_Literal_Acc) return Boolean + is + Cmp : Order; + begin + Cmp := Compare_Value (Arange.Left, Arange.Right); + case Arange.Dir is + when Iir_To => + return Cmp = Greater; + when Iir_Downto => + return Cmp = Less; + end case; + end Is_Nul_Range; + + procedure Increment (Val : Iir_Value_Literal_Acc) is + begin + case Val.Kind is + when Iir_Value_B1 => + if Val.B1 = False then + Val.B1 := True; + else + raise Constraint_Error; + end if; + when Iir_Value_E32 => + Val.E32 := Val.E32 + 1; + when Iir_Value_I64 => + Val.I64 := Val.I64 + 1; + when Iir_Value_F64 + | Iir_Value_Array + | Iir_Value_Record + | Iir_Value_Range + | Iir_Value_File + | Iir_Value_Access + | Iir_Value_Signal + | Iir_Value_Protected + | Iir_Value_Quantity + | Iir_Value_Terminal => + raise Internal_Error; + end case; + end Increment; + + procedure Store (Dest : Iir_Value_Literal_Acc; Src : Iir_Value_Literal_Acc) + is + begin + if Dest.Kind /= Src.Kind then + raise Constraint_Error; + end if; + case Dest.Kind is + when Iir_Value_Array => + if Dest.Val_Array.Len /= Src.Val_Array.Len then + raise Constraint_Error; + end if; + for I in Dest.Val_Array.V'Range loop + Store (Dest.Val_Array.V (I), Src.Val_Array.V (I)); + end loop; + when Iir_Value_Record => + if Dest.Val_Record.Len /= Src.Val_Record.Len then + raise Constraint_Error; + end if; + for I in Dest.Val_Record.V'Range loop + Store (Dest.Val_Record.V (I), Src.Val_Record.V (I)); + end loop; + when Iir_Value_B1 => + Dest.B1 := Src.B1; + when Iir_Value_E32 => + Dest.E32 := Src.E32; + when Iir_Value_I64 => + Dest.I64 := Src.I64; + when Iir_Value_F64 => + Dest.F64 := Src.F64; + when Iir_Value_Access => + Dest.Val_Access := Src.Val_Access; + when Iir_Value_File => + Dest.File := Src.File; + when Iir_Value_Protected => + Dest.Prot := Src.Prot; + when Iir_Value_Signal + | Iir_Value_Range + | Iir_Value_Quantity + | Iir_Value_Terminal => + raise Internal_Error; + end case; + end Store; + + procedure Check_Bounds (Dest : Iir_Value_Literal_Acc; + Src : Iir_Value_Literal_Acc; + Loc : Iir) + is + begin + case Dest.Kind is + when Iir_Value_Array => + if Src.Kind /= Iir_Value_Array then + raise Internal_Error; + end if; + if Dest.Val_Array.Len /= Src.Val_Array.Len then + Error_Msg_Constraint (Loc); + end if; + if Dest.Val_Array.Len /= 0 then + Check_Bounds (Dest.Val_Array.V (1), Src.Val_Array.V (1), Loc); + end if; + when Iir_Value_Record => + if Src.Kind /= Iir_Value_Record then + raise Internal_Error; + end if; + if Dest.Val_Record.Len /= Src.Val_Record.Len then + raise Internal_Error; + end if; + for I in Dest.Val_Record.V'Range loop + Check_Bounds (Dest.Val_Record.V (I), Src.Val_Record.V (I), Loc); + end loop; + when Iir_Value_Access + | Iir_Value_File + | Iir_Value_Range + | Iir_Value_Protected + | Iir_Value_Quantity + | Iir_Value_Terminal => + if Src.Kind /= Dest.Kind then + raise Internal_Error; + end if; + when Iir_Value_B1 + | Iir_Value_E32 + | Iir_Value_I64 + | Iir_Value_F64 + | Iir_Value_Signal => + return; + end case; + end Check_Bounds; + + function To_Iir_Value_Literal_Acc is new Ada.Unchecked_Conversion + (System.Address, Iir_Value_Literal_Acc); + function To_Value_Array_Acc is new Ada.Unchecked_Conversion + (System.Address, Value_Array_Acc); + function To_Value_Bounds_Array_Acc is new Ada.Unchecked_Conversion + (System.Address, Value_Bounds_Array_Acc); + + function Create_Signal_Value (Sig : Ghdl_Signal_Ptr) + return Iir_Value_Literal_Acc + is + subtype Signal_Value is Iir_Value_Literal (Iir_Value_Signal); + function Alloc is new Alloc_On_Pool_Addr (Signal_Value); + begin + return To_Iir_Value_Literal_Acc + (Alloc (Global_Pool'Access, + (Kind => Iir_Value_Signal, Sig => Sig))); + end Create_Signal_Value; + + function Create_Terminal_Value (Terminal : Terminal_Index_Type) + return Iir_Value_Literal_Acc + is + subtype Terminal_Value is Iir_Value_Literal (Iir_Value_Terminal); + function Alloc is new Alloc_On_Pool_Addr (Terminal_Value); + begin + return To_Iir_Value_Literal_Acc + (Alloc (Global_Pool'Access, + (Kind => Iir_Value_Terminal, Terminal => Terminal))); + end Create_Terminal_Value; + + function Create_Quantity_Value (Quantity : Quantity_Index_Type) + return Iir_Value_Literal_Acc + is + subtype Quantity_Value is Iir_Value_Literal (Iir_Value_Quantity); + function Alloc is new Alloc_On_Pool_Addr (Quantity_Value); + begin + return To_Iir_Value_Literal_Acc + (Alloc (Global_Pool'Access, + (Kind => Iir_Value_Quantity, Quantity => Quantity))); + end Create_Quantity_Value; + + function Create_Protected_Value (Prot : Protected_Index_Type) + return Iir_Value_Literal_Acc + is + subtype Protected_Value is Iir_Value_Literal (Iir_Value_Protected); + function Alloc is new Alloc_On_Pool_Addr (Protected_Value); + begin + return To_Iir_Value_Literal_Acc + (Alloc (Global_Pool'Access, + (Kind => Iir_Value_Protected, Prot => Prot))); + end Create_Protected_Value; + + function Create_B1_Value (Val : Ghdl_B1) return Iir_Value_Literal_Acc + is + subtype B1_Value is Iir_Value_Literal (Iir_Value_B1); + function Alloc is new Alloc_On_Pool_Addr (B1_Value); + begin + return To_Iir_Value_Literal_Acc + (Alloc (Current_Pool, (Kind => Iir_Value_B1, B1 => Val))); + end Create_B1_Value; + + function Create_E32_Value (Val : Ghdl_E32) return Iir_Value_Literal_Acc + is + subtype E32_Value is Iir_Value_Literal (Iir_Value_E32); + function Alloc is new Alloc_On_Pool_Addr (E32_Value); + begin + return To_Iir_Value_Literal_Acc + (Alloc (Current_Pool, (Kind => Iir_Value_E32, E32 => Val))); + end Create_E32_Value; + + function Create_I64_Value (Val : Ghdl_I64) return Iir_Value_Literal_Acc + is + subtype I64_Value is Iir_Value_Literal (Iir_Value_I64); + function Alloc is new Alloc_On_Pool_Addr (I64_Value); + begin + return To_Iir_Value_Literal_Acc + (Alloc (Current_Pool, (Kind => Iir_Value_I64, I64 => Val))); + end Create_I64_Value; + + function Create_F64_Value (Val : Ghdl_F64) return Iir_Value_Literal_Acc + is + subtype F64_Value is Iir_Value_Literal (Iir_Value_F64); + function Alloc is new Alloc_On_Pool_Addr (F64_Value); + begin + return To_Iir_Value_Literal_Acc + (Alloc (Current_Pool, (Kind => Iir_Value_F64, F64 => Val))); + end Create_F64_Value; + + function Create_Access_Value (Val : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc + is + subtype Access_Value is Iir_Value_Literal (Iir_Value_Access); + function Alloc is new Alloc_On_Pool_Addr (Access_Value); + begin + return To_Iir_Value_Literal_Acc + (Alloc (Current_Pool, + (Kind => Iir_Value_Access, Val_Access => Val))); + end Create_Access_Value; + + function Create_Range_Value + (Left, Right : Iir_Value_Literal_Acc; + Dir : Iir_Direction; + Length : Iir_Index32) + return Iir_Value_Literal_Acc + is + subtype Range_Value is Iir_Value_Literal (Iir_Value_Range); + function Alloc is new Alloc_On_Pool_Addr (Range_Value); + begin + return To_Iir_Value_Literal_Acc + (Alloc (Current_Pool, + (Kind => Iir_Value_Range, + Left => Left, + Right => Right, + Dir => Dir, + Length => Length))); + end Create_Range_Value; + + function Create_File_Value (Val : Grt.Files.Ghdl_File_Index) + return Iir_Value_Literal_Acc + is + subtype File_Value is Iir_Value_Literal (Iir_Value_File); + function Alloc is new Alloc_On_Pool_Addr (File_Value); + begin + return To_Iir_Value_Literal_Acc + (Alloc (Current_Pool, + (Kind => Iir_Value_File, File => Val))); + end Create_File_Value; + + -- Create a range_value of life LIFE. + function Create_Range_Value + (Left, Right : Iir_Value_Literal_Acc; + Dir : Iir_Direction) + return Iir_Value_Literal_Acc + is + Low, High : Iir_Value_Literal_Acc; + Len : Iir_Index32; + begin + case Dir is + when Iir_To => + Low := Left; + High := Right; + when Iir_Downto => + Low := Right; + High := Left; + end case; + + case (Low.Kind) is + when Iir_Value_B1 => + if High.B1 >= Low.B1 then + Len := Ghdl_B1'Pos (High.B1) - Ghdl_B1'Pos (Low.B1) + 1; + else + Len := 0; + end if; + when Iir_Value_E32 => + if High.E32 >= Low.E32 then + Len := Iir_Index32 (High.E32 - Low.E32 + 1); + else + Len := 0; + end if; + when Iir_Value_I64 => + declare + L : Ghdl_I64; + begin + if High.I64 = Ghdl_I64'Last and Low.I64 = Ghdl_I64'First + then + -- Prevent overflow + Len := Iir_Index32'Last; + else + L := High.I64 - Low.I64; + if L >= Ghdl_I64 (Iir_Index32'Last) then + -- Prevent overflow + Len := Iir_Index32'Last; + else + L := L + 1; + if L < 0 then + -- null range. + Len := 0; + else + Len := Iir_Index32 (L); + end if; + end if; + end if; + end; + when Iir_Value_F64 => + Len := 0; + when Iir_Value_Array + | Iir_Value_Record + | Iir_Value_Access + | Iir_Value_File + | Iir_Value_Range + | Iir_Value_Signal + | Iir_Value_Protected + | Iir_Value_Quantity + | Iir_Value_Terminal => + raise Internal_Error; + end case; + return Create_Range_Value (Left, Right, Dir, Len); + end Create_Range_Value; + + -- Return an array of length LENGTH. + function Create_Array_Value (Dim : Iir_Index32; + Pool : Areapool_Acc := Current_Pool) + return Iir_Value_Literal_Acc + is + subtype Array_Value is Iir_Value_Literal (Iir_Value_Array); + function Alloc_Array is new Alloc_On_Pool_Addr (Array_Value); + subtype Dim_Type is Value_Bounds_Array (Dim); + function Alloc_Bounds is new Alloc_On_Pool_Addr (Dim_Type); + Res : Iir_Value_Literal_Acc; + begin + Res := To_Iir_Value_Literal_Acc + (Alloc_Array (Pool, + (Kind => Iir_Value_Array, + Bounds => null, Val_Array => null))); + + Res.Bounds := To_Value_Bounds_Array_Acc + (Alloc_Bounds (Pool, Dim_Type'(Nbr_Dims => Dim, + D => (others => null)))); + + return Res; + end Create_Array_Value; + + procedure Create_Array_Data (Arr : Iir_Value_Literal_Acc; + Len : Iir_Index32; + Pool : Areapool_Acc := Current_Pool) + is + use System; + subtype Data_Type is Value_Array (Len); + Res : Address; + begin + -- Manually allocate the array to handle large arrays without + -- creating a large temporary value. + Allocate + (Pool.all, Res, Data_Type'Size / Storage_Unit, Data_Type'Alignment); + + declare + -- Discard the warnings for no pragma Import as we really want + -- to use the default initialization. + pragma Warnings (Off); + Addr1 : constant Address := Res; + Init : Data_Type; + for Init'Address use Addr1; + pragma Warnings (On); + begin + null; + end; + + Arr.Val_Array := To_Value_Array_Acc (Res); + end Create_Array_Data; + + function Create_Array_Value (Length: Iir_Index32; + Dim : Iir_Index32; + Pool : Areapool_Acc := Current_Pool) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + begin + Res := Create_Array_Value (Dim, Pool); + Create_Array_Data (Res, Length, Pool); + return Res; + end Create_Array_Value; + + function Create_Record_Value + (Nbr : Iir_Index32; Pool : Areapool_Acc := Current_Pool) + return Iir_Value_Literal_Acc + is + subtype Record_Value is Iir_Value_Literal (Iir_Value_Record); + function Alloc_Record is new Alloc_On_Pool_Addr (Record_Value); + subtype Data_Type is Value_Array (Nbr); + function Alloc_Data is new Alloc_On_Pool_Addr (Data_Type); + Res : Iir_Value_Literal_Acc; + begin + Res := To_Iir_Value_Literal_Acc + (Alloc_Record (Pool, (Kind => Iir_Value_Record, Val_Record => null))); + + Res.Val_Record := To_Value_Array_Acc + (Alloc_Data (Pool, Data_Type'(Len => Nbr, V => (others => null)))); + + return Res; + end Create_Record_Value; + + -- Create a copy of SRC with a specified life. + function Copy (Src: in Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc + is + Res: Iir_Value_Literal_Acc; + begin + case Src.Kind is + when Iir_Value_E32 => + return Create_E32_Value (Src.E32); + when Iir_Value_I64 => + return Create_I64_Value (Src.I64); + when Iir_Value_F64 => + return Create_F64_Value (Src.F64); + when Iir_Value_B1 => + return Create_B1_Value (Src.B1); + when Iir_Value_Access => + return Create_Access_Value (Src.Val_Access); + when Iir_Value_Array => + Res := Copy_Array_Bound (Src); + for I in Src.Val_Array.V'Range loop + Res.Val_Array.V (I) := Copy (Src.Val_Array.V (I)); + end loop; + return Res; + + when Iir_Value_Range => + return Create_Range_Value + (Left => Copy (Src.Left), + Right => Copy (Src.Right), + Dir => Src.Dir, + Length => Src.Length); + + when Iir_Value_Record => + Res := Copy_Record (Src); + for I in Src.Val_Record.V'Range loop + Res.Val_Record.V (I) := Copy (Src.Val_Record.V (I)); + end loop; + return Res; + + when Iir_Value_File => + return Create_File_Value (Src.File); + when Iir_Value_Protected => + return Create_Protected_Value (Src.Prot); + + when Iir_Value_Signal + | Iir_Value_Quantity + | Iir_Value_Terminal => + raise Internal_Error; + end case; + end Copy; + + function Copy_Array_Bound (Src : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + begin + Res := Create_Array_Value (Src.Val_Array.Len, Src.Bounds.Nbr_Dims); + for I in Res.Bounds.D'Range loop + Res.Bounds.D (I) := Copy (Src.Bounds.D (I)); + end loop; + return Res; + end Copy_Array_Bound; + + function Copy_Record (Src : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + return Create_Record_Value (Src.Val_Record.Len); + end Copy_Record; + + function Unshare (Src : Iir_Value_Literal_Acc; Pool : Areapool_Acc) + return Iir_Value_Literal_Acc + is + Prev_Pool : constant Areapool_Acc := Current_Pool; + Res : Iir_Value_Literal_Acc; + begin + Current_Pool := Pool; + Res := Copy (Src); + Current_Pool := Prev_Pool; + return Res; + end Unshare; + + function Unshare_Bounds (Src : Iir_Value_Literal_Acc; Pool : Areapool_Acc) + return Iir_Value_Literal_Acc is + begin + if Src.Kind /= Iir_Value_Array then + return Src; + end if; + declare + Prev_Pool : constant Areapool_Acc := Current_Pool; + Res : Iir_Value_Literal_Acc; + begin + Current_Pool := Pool; + Res := Create_Array_Value (Src.Val_Array.Len, Src.Bounds.Nbr_Dims); + for I in Src.Bounds.D'Range loop + Res.Bounds.D (I) := Copy (Src.Bounds.D (I)); + end loop; + Res.Val_Array.V := Src.Val_Array.V; + Current_Pool := Prev_Pool; + return Res; + end; + end Unshare_Bounds; + + Heap_Pool : aliased Areapool; + + function Unshare_Heap (Src : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + -- FIXME: this is never free. + return Unshare (Src, Heap_Pool'Access); + end Unshare_Heap; + + procedure Free_Heap_Value (Acc : Iir_Value_Literal_Acc) is + begin + null; + end Free_Heap_Value; + + function Get_Nbr_Of_Scalars (Val : Iir_Value_Literal_Acc) return Natural is + begin + case Val.Kind is + when Iir_Value_Scalars + | Iir_Value_Access + | Iir_Value_Signal => + return 1; + when Iir_Value_Record => + declare + Total : Natural := 0; + begin + for I in Val.Val_Record.V'Range loop + Total := Total + Get_Nbr_Of_Scalars (Val.Val_Record.V (I)); + end loop; + return Total; + end; + when Iir_Value_Array => + if Val.Val_Array.Len = 0 then + -- Nul array + return 0; + else + -- At least one element. + return Natural (Val.Val_Array.Len) + * Get_Nbr_Of_Scalars (Val.Val_Array.V (1)); + end if; + when Iir_Value_File + | Iir_Value_Range + | Iir_Value_Protected + | Iir_Value_Terminal + | Iir_Value_Quantity => + raise Internal_Error; + end case; + end Get_Nbr_Of_Scalars; + + function Get_Enum_Pos (Val : Iir_Value_Literal_Acc) return Natural is + begin + case Val.Kind is + when Iir_Value_E32 => + return Ghdl_E32'Pos (Val.E32); + when Iir_Value_B1 => + return Ghdl_B1'Pos (Val.B1); + when others => + raise Internal_Error; + end case; + end Get_Enum_Pos; + + procedure Disp_Value_Tab (Value: Iir_Value_Literal_Acc; + Tab: Ada.Text_IO.Count) + is + use Ada.Text_IO; + use GNAT.Debug_Utilities; + begin + Set_Col (Tab); + if Value = null then + Put_Line ("*NULL*"); + return; + end if; + + if Boolean'(True) then + Put (Image (Value.all'Address) & ' '); + end if; + + case Value.Kind is + when Iir_Value_B1 => + Put_Line ("b1:" & Ghdl_B1'Image (Value.B1)); + when Iir_Value_E32 => + Put_Line ("e32:" & Ghdl_E32'Image (Value.E32)); + when Iir_Value_I64 => + Put_Line ("i64:" & Ghdl_I64'Image (Value.I64)); + when Iir_Value_F64 => + Put_Line ("F64:" & Ghdl_F64'Image (Value.F64)); + when Iir_Value_Access => + -- FIXME. + if Value.Val_Access = null then + Put_Line ("access: null"); + else + Put ("access: "); + Put_Line (Image (Value.Val_Access.all'Address)); + end if; + when Iir_Value_Array => + if Value.Val_Array = null then + Put_Line ("array, without elements"); + return; + else + Put_Line ("array, length: " + & Iir_Index32'Image (Value.Val_Array.Len)); + declare + Ntab: constant Count := Tab + Indentation; + begin + Set_Col (Ntab); + if Value.Bounds /= null then + Put_Line ("bounds 1 .." + & Iir_Index32'Image (Value.Bounds.Nbr_Dims) + & ':'); + for I in Value.Bounds.D'Range loop + Disp_Value_Tab (Value.Bounds.D (I), Ntab); + end loop; + else + Put_Line ("bounds = null"); + end if; + Set_Col (Ntab); + Put_Line ("values 1 .." + & Iir_Index32'Image (Value.Val_Array.Len) + & ':'); + for I in Value.Val_Array.V'Range loop + Disp_Value_Tab (Value.Val_Array.V (I), Ntab); + end loop; + end; + end if; + + when Iir_Value_Range => + Put_Line ("range:"); + Set_Col (Tab); + Put (" direction: "); + Put (Iir_Direction'Image (Value.Dir)); + Put (", length:"); + Put_Line (Iir_Index32'Image (Value.Length)); + if Value.Left /= null then + Set_Col (Tab); + Put (" left bound: "); + Disp_Value_Tab (Value.Left, Col); + end if; + if Value.Right /= null then + Set_Col (Tab); + Put (" right bound: "); + Disp_Value_Tab (Value.Right, Col); + end if; + + when Iir_Value_Record => + Put_Line ("record:"); + for I in Value.Val_Record.V'Range loop + Disp_Value_Tab (Value.Val_Record.V (I), Tab + Indentation); + end loop; + when Iir_Value_Signal => + Put ("signal: "); + if Value.Sig = null then + Put_Line ("(not created)"); + else + Put_Line (Image (Value.Sig.all'Address)); + end if; + + when Iir_Value_File => + Put_Line ("file:" & Grt.Files.Ghdl_File_Index'Image (Value.File)); + when Iir_Value_Protected => + Put_Line ("protected"); + when Iir_Value_Quantity => + Put_Line ("quantity"); + when Iir_Value_Terminal => + Put_Line ("terminal"); + end case; + end Disp_Value_Tab; + + procedure Disp_Value (Value: Iir_Value_Literal_Acc) is + begin + Disp_Value_Tab (Value, 1); + end Disp_Value; + + -- Return TRUE if VALUE has an indirect value. + function Is_Indirect (Value : Iir_Value_Literal_Acc) return Boolean is + begin + case Value.Kind is + when Iir_Value_Scalars + | Iir_Value_Access + | Iir_Value_File + | Iir_Value_Protected + | Iir_Value_Quantity + | Iir_Value_Terminal => + return False; + when Iir_Value_Range => + return Is_Indirect (Value.Left) + or else Is_Indirect (Value.Right); + when Iir_Value_Array => + for I in Value.Val_Array.V'Range loop + if Is_Indirect (Value.Val_Array.V (I)) then + return True; + end if; + end loop; + return False; + when Iir_Value_Record => + for I in Value.Val_Record.V'Range loop + if Is_Indirect (Value.Val_Record.V (I)) then + return True; + end if; + end loop; + return False; + when Iir_Value_Signal => + return True; + end case; + end Is_Indirect; + + procedure Disp_Iir_Value_Array (Value: Iir_Value_Literal_Acc; + A_Type: Iir; + Dim: Iir_Index32; + Off : in out Iir_Index32) + is + use Ada.Text_IO; + type Last_Enum_Type is (None, Char, Identifier); + Last_Enum: Last_Enum_Type; + El_Type: Iir; + Enum_List: Iir_List; + El_Id : Name_Id; + El_Pos : Natural; + begin + if Dim = Value.Bounds.Nbr_Dims then + -- Last dimension + El_Type := Get_Base_Type (Get_Element_Subtype (A_Type)); + + -- Pretty print vectors of enumerated types + if Get_Kind (El_Type) = Iir_Kind_Enumeration_Type_Definition + and then not Is_Indirect (Value) + then + Last_Enum := None; + Enum_List := Get_Enumeration_Literal_List (El_Type); + for I in 1 .. Value.Bounds.D (Dim).Length loop + El_Pos := Get_Enum_Pos (Value.Val_Array.V (Off)); + Off := Off + 1; + El_Id := Get_Identifier (Get_Nth_Element (Enum_List, El_Pos)); + if Name_Table.Is_Character (El_Id) then + case Last_Enum is + when None => + Put (""""); + when Identifier => + Put (" & """); + when Char => + null; + end case; + Put (Name_Table.Get_Character (El_Id)); + Last_Enum := Char; + else + case Last_Enum is + when None => + null; + when Identifier => + Put (" & "); + when Char => + Put (""" & "); + end case; + Put (Name_Table.Image (El_Id)); + Last_Enum := Identifier; + end if; + end loop; + case Last_Enum is + when None => + Put (""""); + when Identifier => + null; + when Char => + Put (""""); + end case; + else + Put ("("); + for I in 1 .. Value.Bounds.D (Dim).Length loop + if I /= 1 then + Put (", "); + end if; + Disp_Iir_Value (Value.Val_Array.V (Off), El_Type); + Off := Off + 1; + end loop; + Put (")"); + end if; + else + Put ("("); + for I in 1 .. Value.Bounds.D (Dim).Length loop + if I /= 1 then + Put (", "); + end if; + Disp_Iir_Value_Array (Value, A_Type, Dim + 1, Off); + end loop; + Put (")"); + end if; + end Disp_Iir_Value_Array; + + procedure Disp_Iir_Value_Record + (Value: Iir_Value_Literal_Acc; A_Type: Iir) + is + use Ada.Text_IO; + El : Iir_Element_Declaration; + List : Iir_List; + begin + List := Get_Elements_Declaration_List (Get_Base_Type (A_Type)); + Put ("("); + for I in Value.Val_Record.V'Range loop + El := Get_Nth_Element (List, Natural (I - 1)); + if I /= 1 then + Put (", "); + end if; + Put (Name_Table.Image (Get_Identifier (El))); + Put (" => "); + Disp_Iir_Value (Value.Val_Record.V (I), Get_Type (El)); + end loop; + Put (")"); + end Disp_Iir_Value_Record; + + procedure Disp_Iir_Value (Value: Iir_Value_Literal_Acc; A_Type: Iir) is + use Ada.Text_IO; + begin + if Value = null then + Put ("!NULL!"); + return; + end if; + case Value.Kind is + when Iir_Value_I64 => + Put (Ghdl_I64'Image (Value.I64)); + when Iir_Value_F64 => + Put (Ghdl_F64'Image (Value.F64)); + when Iir_Value_E32 + | Iir_Value_B1 => + declare + Bt : constant Iir := Get_Base_Type (A_Type); + Id : Name_Id; + Pos : Integer; + begin + if Value.Kind = Iir_Value_E32 then + Pos := Ghdl_E32'Pos (Value.E32); + else + Pos := Ghdl_B1'Pos (Value.B1); + end if; + Id := Get_Identifier + (Get_Nth_Element (Get_Enumeration_Literal_List (Bt), Pos)); + Put (Name_Table.Image (Id)); + end; + when Iir_Value_Access => + if Value.Val_Access = null then + Put ("null"); + else + -- FIXME. + Put ("*acc*"); + end if; + when Iir_Value_Array => + declare + Off : Iir_Index32; + begin + Off := 1; + Disp_Iir_Value_Array (Value, A_Type, 1, Off); + pragma Assert (Off = Value.Val_Array.Len + 1); + end; + when Iir_Value_File => + raise Internal_Error; + when Iir_Value_Record => + Disp_Iir_Value_Record (Value, A_Type); + when Iir_Value_Range => + -- FIXME. + raise Internal_Error; + when Iir_Value_Quantity => + Put ("[quantity]"); + when Iir_Value_Terminal => + Put ("[terminal]"); + when Iir_Value_Signal => + Put ("[signal]"); + when Iir_Value_Protected => + Put ("[protected]"); + end case; + end Disp_Iir_Value; +end Iir_Values; diff --git a/src/simulate/iir_values.ads b/src/simulate/iir_values.ads new file mode 100644 index 000000000..699ab883a --- /dev/null +++ b/src/simulate/iir_values.ads @@ -0,0 +1,355 @@ +-- Naive values for interpreted simulation +-- Copyright (C) 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 GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Ada.Text_IO; +with Types; use Types; +with Iirs; use Iirs; +with Grt.Types; use Grt.Types; +with Grt.Signals; use Grt.Signals; +with Grt.Files; +with Areapools; use Areapools; +-- with System.Debug_Pools; + +package Iir_Values is + -- During simulation, all values are contained into objects of type + -- iir_value_literal. The annotation pass creates such objects for every + -- literal of units. The elaboration pass creates such objects for + -- signals, variables, contants... + -- The simulator uses iir_value_literal for intermediate results, for + -- computed values... + + -- There is several kinds of iir_value_literal, mainly depending on the + -- type of the value: + -- + -- iir_value_e32: + -- the value is an enumeration literal. The enum field contains the + -- position of the literal (same as 'pos). + -- + -- iir_value_i64: + -- the value is an integer. + -- + -- iir_value_f64: + -- the value is a floating point. + -- + -- iir_value_range: + -- Boundaries and direction. + -- + -- iir_value_array: + -- All the values are contained in the array Val_Array. + -- Boundaries of the array are contained in the array BOUNDS, one element + -- per dimension, from 1 to number of dimensions. + -- + -- iir_value_signal: + -- Special case: the iir_value_literal designates a signal. + -- + -- iir_value_record + -- For records. + -- + -- iir_value_access + -- for accesses. + -- + -- iir_value_file + -- for files. + + -- Memory management: + -- The values are always allocated on areapool, which uses a mark/release + -- management. A release operation frees all the memory of the areapool + -- allocated since the mark. This memory management is very efficient. + -- + -- There is one areapool per processes; there is one mark per instances. + -- Objects (variables, signals, constants, iterators, ...) are allocated + -- on the per-process pool. When an activation frame is created (due + -- to a call to a subprogram), a mark is saved. When the activation frame + -- is removed (due to a return from subprogram), the memory is released to + -- the mark. That's simple. + -- + -- Objects for the process is allocated in that areapool, but never + -- released (could be if the process is waiting forever if the user don't + -- need to inspect values). + -- + -- Signals and constants for blocks/entity/architecture are allocated on + -- a global pool. + -- + -- In fact this is not so simple because of functions: they return a + -- value. The current solution is to compute every expressions on a + -- expression pool (only one is needed as the computation cannot be + -- suspended), use the result (copy in case of assignment or return), and + -- release that pool. + -- + -- It is highly recommended to share values as much as possible for + -- expressions (for example, alias the values of 'others =>'). Do not + -- share values for names, but be sure to keep the original nodes. + -- ??? In fact sharing is required to pass actual by references. + -- When an object is created, be sure to unshare the values. This is + -- usually achieved by Copy. + -- + -- Finally, a pool is also needed during elaboration (as elaboration is + -- not done within the context of a process). + + type Iir_Value_Kind is + (Iir_Value_B1, Iir_Value_E32, + Iir_Value_I64, Iir_Value_F64, + Iir_Value_Access, + Iir_Value_File, + Iir_Value_Range, + Iir_Value_Array, Iir_Value_Record, + Iir_Value_Protected, + Iir_Value_Signal, + Iir_Value_Terminal, + Iir_Value_Quantity); + + type Protected_Index_Type is new Natural; + + type Quantity_Index_Type is new Natural; + type Terminal_Index_Type is new Natural; + + -- Scalar values. Only these ones can be signals. + subtype Iir_Value_Scalars is + Iir_Value_Kind range Iir_Value_B1 .. Iir_Value_F64; + + type Iir_Value_Literal (Kind: Iir_Value_Kind); + + type Iir_Value_Literal_Acc is access Iir_Value_Literal; + + -- Must start at 0. + -- Thus, length of the array is val_array'last - 1. + type Iir_Value_Literal_Array is array (Iir_Index32 range <>) of + Iir_Value_Literal_Acc; + + type Iir_Value_Literal_Array_Acc is access Iir_Value_Literal_Array; + + type Value_Bounds_Array (Nbr_Dims : Iir_Index32) is record + D : Iir_Value_Literal_Array (1 .. Nbr_Dims); + end record; + + type Value_Bounds_Array_Acc is access Value_Bounds_Array; + + type Value_Array (Len : Iir_Index32) is record + V : Iir_Value_Literal_Array (1 .. Len); + end record; + + type Value_Array_Acc is access Value_Array; + + type Iir_Value_Literal (Kind: Iir_Value_Kind) is record + case Kind is + when Iir_Value_B1 => + B1 : Ghdl_B1; + when Iir_Value_E32 => + E32 : Ghdl_E32; + when Iir_Value_I64 => + I64 : Ghdl_I64; + when Iir_Value_F64 => + F64 : Ghdl_F64; + when Iir_Value_Access => + Val_Access: Iir_Value_Literal_Acc; + when Iir_Value_File => + File: Grt.Files.Ghdl_File_Index; + when Iir_Value_Array => + Val_Array: Value_Array_Acc; -- range 1 .. N + Bounds : Value_Bounds_Array_Acc; -- range 1 .. Dim + when Iir_Value_Record => + Val_Record: Value_Array_Acc; -- range 1 .. N + when Iir_Value_Signal => + Sig : Ghdl_Signal_Ptr; + when Iir_Value_Protected => + Prot : Protected_Index_Type; + when Iir_Value_Quantity => + Quantity : Quantity_Index_Type; + when Iir_Value_Terminal => + Terminal : Terminal_Index_Type; + when Iir_Value_Range => + Dir: Iir_Direction; + Length : Iir_Index32; + Left: Iir_Value_Literal_Acc; + Right: Iir_Value_Literal_Acc; + end case; + end record; + + -- What is chosen for time. + -- Currently only int32 is available, but time should use an int64. + subtype Iir_Value_Time is Ghdl_I64; + + Global_Pool : aliased Areapool; + Expr_Pool : aliased Areapool; + + -- Areapool used by Create_*_Value + Current_Pool : Areapool_Acc := Expr_Pool'Access; + + -- Pool for objects allocated in the current instance. + Instance_Pool : Areapool_Acc; + + function Create_Signal_Value (Sig : Ghdl_Signal_Ptr) + return Iir_Value_Literal_Acc; + + function Create_Terminal_Value (Terminal : Terminal_Index_Type) + return Iir_Value_Literal_Acc; + + function Create_Quantity_Value (Quantity : Quantity_Index_Type) + return Iir_Value_Literal_Acc; + + function Create_B1_Value (Val : Ghdl_B1) return Iir_Value_Literal_Acc; + + function Create_E32_Value (Val : Ghdl_E32) return Iir_Value_Literal_Acc; + + -- Return an iir_value_literal_acc (iir_value_int64). + function Create_I64_Value (Val : Ghdl_I64) return Iir_Value_Literal_Acc; + + -- Return an iir_value_literal_acc (iir_value_fp64) + function Create_F64_Value (Val : Ghdl_F64) return Iir_Value_Literal_Acc; + + function Create_Access_Value (Val : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc; + + function Create_File_Value (Val : Grt.Files.Ghdl_File_Index) + return Iir_Value_Literal_Acc; + + function Create_Protected_Value (Prot : Protected_Index_Type) + return Iir_Value_Literal_Acc; + + -- Return an iir_value_literal (iir_value_record) of NBR elements. + function Create_Record_Value + (Nbr : Iir_Index32; Pool : Areapool_Acc := Current_Pool) + return Iir_Value_Literal_Acc; + + -- Allocate array and the dimension vector (but bounds and values aren't + -- allocated). + function Create_Array_Value (Dim : Iir_Index32; + Pool : Areapool_Acc := Current_Pool) + return Iir_Value_Literal_Acc; + + -- Allocate the Val_Array vector. + procedure Create_Array_Data (Arr : Iir_Value_Literal_Acc; + Len : Iir_Index32; + Pool : Areapool_Acc := Current_Pool); + + -- Return an array of length LENGTH and DIM bounds. + -- If DIM is 0, then the bounds array is not allocated. + function Create_Array_Value (Length: Iir_Index32; + Dim : Iir_Index32; + Pool : Areapool_Acc := Current_Pool) + return Iir_Value_Literal_Acc; + + -- Create a range_value of life LIFE. + function Create_Range_Value + (Left, Right : Iir_Value_Literal_Acc; + Dir : Iir_Direction; + Length : Iir_Index32) + return Iir_Value_Literal_Acc; + + -- Create a range_value (compute the length) + function Create_Range_Value + (Left, Right : Iir_Value_Literal_Acc; + Dir : Iir_Direction) + return Iir_Value_Literal_Acc; + + -- Return true if the value of LEFT and RIGHT are equal. + -- Return false if they are not equal. + -- Raise constraint_error if the types differes. + -- Value or sub-value must not be indirect. + function Is_Equal (Left, Right: Iir_Value_Literal_Acc) return Boolean; + + -- Return TRUE iif ARANGE is a nul range. + function Is_Nul_Range (Arange : Iir_Value_Literal_Acc) return Boolean; + + -- Get order of LEFT with RIGHT. + -- Must be discrete kind (enum, int, fp, physical) or array (uni dim). + type Order is (Less, Equal, Greater); + function Compare_Value (Left, Right : Iir_Value_Literal_Acc) + return Order; + + -- Check that SRC has the same structure as DEST. Report an error at + -- LOC if not. + procedure Check_Bounds (Dest : Iir_Value_Literal_Acc; + Src : Iir_Value_Literal_Acc; + Loc : Iir); + + -- Store (by copy) SRC into DEST. + -- The type must be equal (otherwise constraint_error is raised). + -- Life of DEST must be Target, otherwise program_error is raised. + -- Value or sub-value must not be indirect. + procedure Store (Dest : Iir_Value_Literal_Acc; Src : Iir_Value_Literal_Acc); + + -- Create a copy of SRC allocated in POOL. + function Unshare (Src : Iir_Value_Literal_Acc; Pool : Areapool_Acc) + return Iir_Value_Literal_Acc; + + -- If SRC is an array, just copy the bounds in POOL and return it. + -- Otherwise return SRC. Values are always kept, so that this could + -- be used by alias declarations. + function Unshare_Bounds (Src : Iir_Value_Literal_Acc; Pool : Areapool_Acc) + return Iir_Value_Literal_Acc; + + -- Create a copy of SRC on the heap. + function Unshare_Heap (Src : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc; + + -- Deallocate value accessed by ACC. + procedure Free_Heap_Value (Acc : Iir_Value_Literal_Acc); + + -- Increment. + -- VAL must be of kind integer or enumeration. + -- VAL must be of life temporary. + procedure Increment (Val : Iir_Value_Literal_Acc); + + -- Copy BOUNDS of SRC with a specified life. + -- Note: val_array is allocated but not filled. + function Copy_Array_Bound (Src : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc; + + -- Copy the bounds (well the array containing the values) of SRC. + -- Val_record is allocated but not filled. + function Copy_Record (Src : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc; + + -- Return the number of scalars elements in VALS. + function Get_Nbr_Of_Scalars (Val : Iir_Value_Literal_Acc) return Natural; + + -- Return the position of an enumerated type value. + function Get_Enum_Pos (Val : Iir_Value_Literal_Acc) return Natural; + + -- Well known values. + -- Boolean_to_lit can be used to convert a boolean value from Ada to a + -- boolean value for vhdl. + type Lit_Enum_Type is array (Boolean) of Iir_Value_Literal_Acc; + Lit_Enum_0 : constant Iir_Value_Literal_Acc := + new Iir_Value_Literal'(Kind => Iir_Value_B1, + B1 => False); + Lit_Enum_1 : constant Iir_Value_Literal_Acc := + new Iir_Value_Literal'(Kind => Iir_Value_B1, + B1 => True); + Boolean_To_Lit: constant Lit_Enum_Type := + (False => Lit_Enum_0, True => Lit_Enum_1); + Lit_Boolean_False: Iir_Value_Literal_Acc + renames Boolean_To_Lit (False); + Lit_Boolean_True: Iir_Value_Literal_Acc + renames Boolean_To_Lit (True); + + -- Literal NULL. + Null_Lit: constant Iir_Value_Literal_Acc := + new Iir_Value_Literal'(Kind => Iir_Value_Access, + Val_Access => null); + + -- Disp a value_literal in raw form. + procedure Disp_Value (Value: Iir_Value_Literal_Acc); + procedure Disp_Value_Tab (Value: Iir_Value_Literal_Acc; + Tab: Ada.Text_IO.Count); + + -- Disp a value_literal in readable form. + procedure Disp_Iir_Value (Value: Iir_Value_Literal_Acc; A_Type: Iir); +end Iir_Values; + diff --git a/src/simulate/sim_be.adb b/src/simulate/sim_be.adb new file mode 100644 index 000000000..49a146879 --- /dev/null +++ b/src/simulate/sim_be.adb @@ -0,0 +1,117 @@ +-- Interpreter back-end +-- Copyright (C) 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 GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Ada.Text_IO; +with Sem; +with Canon; +with Annotations; +with Disp_Tree; +with Errorout; use Errorout; +with Flags; +with Disp_Vhdl; +with Post_Sems; + +package body Sim_Be is + procedure Finish_Compilation (Unit: Iir_Design_Unit; Main: Boolean := False) + is + use Ada.Text_IO; + Lib_Unit : Iir; + begin + Lib_Unit := Get_Library_Unit (Unit); + -- Semantic analysis. + if Flags.Verbose then + Put_Line ("semantize " & Disp_Node (Lib_Unit)); + end if; + Sem.Semantic (Unit); + + if (Main or Flags.Dump_All) and then Flags.Dump_Sem then + Disp_Tree.Disp_Tree (Unit); + end if; + + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + + if (Main or Flags.List_All) and then Flags.List_Sem then + Disp_Vhdl.Disp_Vhdl (Unit); + end if; + + -- Post checks + ---------------- + + Post_Sems.Post_Sem_Checks (Unit); + + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + + + -- Canonicalisation. + ------------------ + if Flags.Verbose then + Put_Line ("canonicalize " & Disp_Node (Lib_Unit)); + end if; + + Canon.Canonicalize (Unit); + + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + + if (Main or Flags.List_All) and then Flags.List_Canon then + Disp_Vhdl.Disp_Vhdl (Unit); + end if; + + if Flags.Flag_Elaborate then + if Get_Kind (Lib_Unit) = Iir_Kind_Architecture_Body then + declare + Config : Iir_Design_Unit; + begin + Config := Canon.Create_Default_Configuration_Declaration + (Lib_Unit); + Set_Default_Configuration_Declaration (Lib_Unit, Config); + if (Main or Flags.Dump_All) and then Flags.Dump_Canon then + Disp_Tree.Disp_Tree (Config); + end if; + if (Main or Flags.List_All) and then Flags.List_Canon then + Disp_Vhdl.Disp_Vhdl (Config); + end if; + end; + end if; + end if; + + -- Annotation. + ------------- + if Flags.Verbose then + Put_Line ("annotate " & Disp_Node (Lib_Unit)); + end if; + + Annotations.Annotate (Unit); + + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + + if (Main or Flags.List_All) and then Flags.List_Annotate then + Disp_Vhdl.Disp_Vhdl (Unit); + end if; + if (Main or Flags.Dump_All) and then Flags.Dump_Annotate then + Disp_Tree.Disp_Tree (Unit); + end if; + end Finish_Compilation; +end Sim_Be; diff --git a/src/simulate/sim_be.ads b/src/simulate/sim_be.ads new file mode 100644 index 000000000..9256c4b68 --- /dev/null +++ b/src/simulate/sim_be.ads @@ -0,0 +1,25 @@ +-- Interpreter back-end +-- Copyright (C) 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 GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Iirs; use Iirs; + +package Sim_Be is + procedure Finish_Compilation + (Unit: Iir_Design_Unit; Main: Boolean := False); +end Sim_Be; + diff --git a/src/simulate/simulation-ams-debugger.adb b/src/simulate/simulation-ams-debugger.adb new file mode 100644 index 000000000..9cdbc75b2 --- /dev/null +++ b/src/simulate/simulation-ams-debugger.adb @@ -0,0 +1,87 @@ +-- Interpreter AMS simulation +-- Copyright (C) 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 GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Debugger; use Debugger; +with Iirs_Utils; use Iirs_Utils; +with Ada.Text_IO; use Ada.Text_IO; +with Disp_Vhdl; + +package body Simulation.AMS.Debugger is + procedure Disp_Quantity_Name (Quantity : Quantity_Index_Type) + is + Obj : Scalar_Quantity renames Scalar_Quantities.Table (Quantity); + begin + Disp_Instance_Name (Obj.Instance, True); + Put ('.'); + Put (Image_Identifier (Obj.Decl)); + if Obj.Kind = Quantity_Reference then + Put ("'Ref"); + end if; + end Disp_Quantity_Name; + + procedure Disp_Term (Term : Ams_Term_Acc) is + begin + case Term.Sign is + when Op_Plus => + Put (" + "); + when Op_Minus => + Put (" - "); + end case; + + case Term.Op is + when Op_Quantity => + Disp_Quantity_Name (Term.Quantity); + when Op_Vhdl_Expr => + Disp_Vhdl.Disp_Expression (Term.Vhdl_Expr); + end case; + end Disp_Term; + + procedure Disp_Characteristic_Expression + (Ce : Characteristic_Expressions_Index) + is + Obj : Characteristic_Expr renames + Characteristic_Expressions.Table (Ce); + Expr : Ams_Term_Acc := Obj.Expr; + begin + case Obj.Kind is + when Explicit => + Put ("Explic:"); + when Contribution => + Put ("Contri:"); + when Structural => + Put ("Struct:"); + end case; + + while Expr /= null loop + Disp_Term (Expr); + Expr := Expr.Next; + end loop; + New_Line; + end Disp_Characteristic_Expression; + + procedure Disp_Characteristic_Expressions is + begin + Put_Line ("Characteristic expressions:"); + for I in Characteristic_Expressions.First + .. Characteristic_Expressions.Last + loop + Disp_Characteristic_Expression (I); + end loop; + end Disp_Characteristic_Expressions; +end Simulation.AMS.Debugger; + diff --git a/src/simulate/simulation-ams-debugger.ads b/src/simulate/simulation-ams-debugger.ads new file mode 100644 index 000000000..0cfcdedc7 --- /dev/null +++ b/src/simulate/simulation-ams-debugger.ads @@ -0,0 +1,27 @@ +-- Interpreter AMS simulation +-- Copyright (C) 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 GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +package Simulation.AMS.Debugger is + procedure Disp_Quantity_Name (Quantity : Quantity_Index_Type); + + procedure Disp_Characteristic_Expression + (Ce : Characteristic_Expressions_Index); + + procedure Disp_Characteristic_Expressions; +end Simulation.AMS.Debugger; + diff --git a/src/simulate/simulation-ams.adb b/src/simulate/simulation-ams.adb new file mode 100644 index 000000000..31dd43e0e --- /dev/null +++ b/src/simulate/simulation-ams.adb @@ -0,0 +1,201 @@ +-- Interpreter AMS simulation +-- Copyright (C) 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 GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Errorout; use Errorout; + +package body Simulation.AMS is + function Create_Characteristic_Expression + (Kind : Characteristic_Expr_Kind) + return Characteristic_Expressions_Index + is + begin + case Kind is + when Contribution => + Characteristic_Expressions.Append + ((Kind => Contribution, + Expr => null, + Tolerance => 0, + Dependencies => null)); + when others => + raise Program_Error; + end case; + return Characteristic_Expressions.Last; + end Create_Characteristic_Expression; + + function Create_Scalar_Quantity (Kind : Quantity_Kind; + Decl : Iir; + Instance : Block_Instance_Acc) + return Quantity_Index_Type + is + begin + case Kind is + when Quantity_Reference => + Scalar_Quantities.Append + ((Kind => Quantity_Reference, + Value => 0.0, + Decl => Decl, + Instance => Instance, + Contribution => + Create_Characteristic_Expression (Contribution))); + when Quantity_Across => + Scalar_Quantities.Append + ((Kind => Quantity_Across, + Value => 0.0, + Decl => Decl, + Instance => Instance)); + when Quantity_Through => + Scalar_Quantities.Append + ((Kind => Quantity_Through, + Value => 0.0, + Decl => Decl, + Instance => Instance)); + when others => + raise Program_Error; + end case; + return Scalar_Quantities.Last; + end Create_Scalar_Quantity; + + function Create_Scalar_Terminal (Decl : Iir; + Instance : Block_Instance_Acc) + return Terminal_Index_Type + is + begin + -- Simply create the reference quantity for a terminal + return Terminal_Index_Type + (Create_Scalar_Quantity (Quantity_Reference, Decl, Instance)); + end Create_Scalar_Terminal; + + function Get_Terminal_Reference (Terminal : Terminal_Index_Type) + return Quantity_Index_Type is + begin + return Quantity_Index_Type (Terminal); + end Get_Terminal_Reference; + + procedure Add_Characteristic_Expression + (Kind : Characteristic_Expr_Kind; Expr : Ams_Term_Acc) + is + begin + Characteristic_Expressions.Append + ((Kind => Kind, + Expr => Expr, + Tolerance => Default_Tolerance_Index, + Dependencies => null)); + end Add_Characteristic_Expression; + + procedure Compute_Dependencies (Idx : Characteristic_Expressions_Index) + is + package Quantity_Table is new GNAT.Table + (Table_Component_Type => Quantity_Index_Type, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 16, + Table_Increment => 100); + + El : Characteristic_Expr renames Characteristic_Expressions.Table (Idx); + Res : Quantity_Dependency_Acc := null; + + procedure Add_Dependency (Block : Block_Instance_Acc; N : Iir) + is + Q : Iir_Value_Literal_Acc; + begin + case Get_Kind (N) is + when Iir_Kinds_Branch_Quantity_Declaration => + Q := Execute_Name (Block, N, True); + Quantity_Table.Append (Q.Quantity); + when Iir_Kind_Simple_Name => + Add_Dependency (Block, Get_Named_Entity (N)); + when Iir_Kinds_Dyadic_Operator => + Add_Dependency (Block, Get_Left (N)); + Add_Dependency (Block, Get_Right (N)); + when Iir_Kinds_Literal => + null; + when others => + Error_Kind ("compute_dependencies", N); + end case; + end Add_Dependency; + + Term : Ams_Term_Acc := El.Expr; + begin + pragma Assert (El.Dependencies = null); + + while Term /= null loop + case Term.Op is + when Op_Quantity => + Quantity_Table.Append (Term.Quantity); + when Op_Vhdl_Expr => + Add_Dependency (Term.Vhdl_Instance, Term.Vhdl_Expr); + end case; + Term := Term.Next; + end loop; + Res := new Quantity_Dependency_Type (Nbr => Quantity_Table.Last); + for I in Quantity_Table.First .. Quantity_Table.Last loop + Res.Quantities (I) := Quantity_Table.Table (I); + end loop; + Quantity_Table.Free; + El.Dependencies := Res; + end Compute_Dependencies; + + function Build (Op : Ams_Sign; + Val : Quantity_Index_Type; + Right : Ams_Term_Acc := null) + return Ams_Term_Acc + is + begin + return new Ams_Term'(Op => Op_Quantity, + Sign => Op, + Next => Right, + Quantity => Val); + end Build; + + function Build (Op : Ams_Sign; + Instance : Block_Instance_Acc; + Expr : Iir; + Right : Ams_Term_Acc := null) + return Ams_Term_Acc + is + begin + return new Ams_Term' + (Op => Op_Vhdl_Expr, + Sign => Op, + Vhdl_Expr => Expr, + Vhdl_Instance => Instance, + Next => Right); + end Build; + + procedure Append_Characteristic_Expression + (Terminal : Terminal_Index_Type; Expr : Ams_Term_Acc) + is + Ref : constant Quantity_Index_Type := Get_Terminal_Reference (Terminal); + Ce : constant Characteristic_Expressions_Index := + Scalar_Quantities.Table (Ref).Contribution; + begin + pragma Assert (Expr.Next = null); + Expr.Next := Characteristic_Expressions.Table (Ce).Expr; + Characteristic_Expressions.Table (Ce).Expr := Expr; + end Append_Characteristic_Expression; + + procedure Create_Tables is + begin + for I in Characteristic_Expressions.First + .. Characteristic_Expressions.Last + loop + Compute_Dependencies (I); + end loop; + end Create_Tables; +end Simulation.AMS; + diff --git a/src/simulate/simulation-ams.ads b/src/simulate/simulation-ams.ads new file mode 100644 index 000000000..8ca513652 --- /dev/null +++ b/src/simulate/simulation-ams.ads @@ -0,0 +1,165 @@ +-- Interpreter AMS simulation +-- Copyright (C) 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 GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with GNAT.Table; + +package Simulation.AMS is + -- AMS expressions + -- + -- At many places during elaboration, the LRM defines characteristic + -- expressions that aren't present in source code: + -- * contribution expression (12.3.1.4) + -- * characteristic expression for an across quantity declaration + -- (12.3.1.4) + -- * characteristic expression for simple simultaneous statement (the + -- expression is in the source in that case) (15.1) + -- + -- They are represented using a list of Ams_Expression elements. The value + -- is the sum of each element, using the + or - sign. + + type Ams_Sign is (Op_Plus, Op_Minus); + -- Sign for the operand + + type Ams_Operand is (Op_Quantity, Op_Vhdl_Expr); + -- The operand is one of: + -- Op_Quantity: a quantity + -- Op_Vhdl_Expr: an expression from the design. This expression may contain + -- quantities + + type Ams_Term (<>) is private; + type Ams_Term_Acc is access Ams_Term; + -- A term of a characteristic expression + + type Characteristic_Expr_Kind is + (Explicit, + Contribution, + Structural); + + type Tolerance_Index_Type is new Natural; + Default_Tolerance_Index : constant Tolerance_Index_Type := 0; + -- Tolerance + + type Characteristic_Expressions_Index is new Natural; + + type Quantity_Kind is + (Quantity_Reference, + -- The potential of a terminal. This is an across quantity between the + -- terminal and the reference terminal of the nature. + + Quantity_Across, + Quantity_Through, + Quantity_Free + -- Explicitly declared quantities + ); + + function Create_Scalar_Quantity (Kind : Quantity_Kind; + Decl : Iir; + Instance : Block_Instance_Acc) + return Quantity_Index_Type; + -- Create a new scalar quantity + + function Create_Scalar_Terminal (Decl : Iir; + Instance : Block_Instance_Acc) + return Terminal_Index_Type; + -- Create a new scalar terminal + + function Get_Terminal_Reference (Terminal : Terminal_Index_Type) + return Quantity_Index_Type; + -- Get the reference quantity of a terminal + + procedure Add_Characteristic_Expression + (Kind : Characteristic_Expr_Kind; Expr : Ams_Term_Acc); + -- Add a new characteristic expression + + function Build (Op : Ams_Sign; + Val : Quantity_Index_Type; + Right : Ams_Term_Acc := null) + return Ams_Term_Acc; + function Build (Op : Ams_Sign; + Instance : Block_Instance_Acc; + Expr : Iir; + Right : Ams_Term_Acc := null) + return Ams_Term_Acc; + -- Build a term of a characteristic expression + + procedure Append_Characteristic_Expression + (Terminal : Terminal_Index_Type; Expr : Ams_Term_Acc); + -- Append an expression to the contribution of a terminal + + procedure Create_Tables; +private + type Quantity_Index_Array is array (Positive range <>) + of Quantity_Index_Type; + + type Quantity_Dependency_Type (Nbr : Natural); + type Quantity_Dependency_Acc is access Quantity_Dependency_Type; + + type Quantity_Dependency_Type (Nbr : Natural) is record + Quantities : Quantity_Index_Array (1 .. Nbr); + end record; + + type Ams_Term (Op : Ams_Operand) is record + Sign : Ams_Sign; + Next : Ams_Term_Acc; + + case Op is + when Op_Quantity => + Quantity : Quantity_Index_Type; + when Op_Vhdl_Expr => + Vhdl_Expr : Iir; + Vhdl_Instance : Block_Instance_Acc; + end case; + end record; + + type Characteristic_Expr is record + Kind : Characteristic_Expr_Kind; + Expr : Ams_Term_Acc; + Tolerance : Tolerance_Index_Type; + Dependencies : Quantity_Dependency_Acc; + end record; + + package Characteristic_Expressions is new Gnat.Table + (Table_Index_Type => Characteristic_Expressions_Index, + Table_Component_Type => Characteristic_Expr, + Table_Low_Bound => 1, + Table_Initial => 128, + Table_Increment => 100); + + type Scalar_Quantity (Kind : Quantity_Kind := Quantity_Reference) is record + Value : Ghdl_F64; + -- The value of the quantity + + Decl : Iir; + Instance : Block_Instance_Acc; + -- Declaration for the quantity + + case Kind is + when Quantity_Reference => + Contribution : Characteristic_Expressions_Index; + when others => + null; + end case; + end record; + + package Scalar_Quantities is new Gnat.Table + (Table_Index_Type => Quantity_Index_Type, + Table_Component_Type => Scalar_Quantity, + Table_Low_Bound => 1, + Table_Initial => 128, + Table_Increment => 100); +end Simulation.AMS; diff --git a/src/simulate/simulation.adb b/src/simulate/simulation.adb new file mode 100644 index 000000000..3f3f8715b --- /dev/null +++ b/src/simulate/simulation.adb @@ -0,0 +1,1669 @@ +-- Interpreted simulation +-- Copyright (C) 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 GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Ada.Unchecked_Conversion; +with Ada.Text_IO; use Ada.Text_IO; +with Errorout; use Errorout; +with Iirs_Utils; use Iirs_Utils; +with Trans_Analyzes; +with Types; use Types; +with Debugger; use Debugger; +with Simulation.AMS.Debugger; +with Areapools; use Areapools; +with Grt.Stacks; +with Grt.Signals; +with Grt.Processes; +with Grt.Main; +with Grt.Errors; +with Grt.Rtis; + +package body Simulation is + + function Value_To_Iir_Value (Mode : Mode_Type; Val : Value_Union) + return Iir_Value_Literal_Acc is + begin + case Mode is + when Mode_B1 => + return Create_B1_Value (Val.B1); + when Mode_E32 => + return Create_E32_Value (Val.E32); + when Mode_I64 => + return Create_I64_Value (Val.I64); + when Mode_F64 => + return Create_F64_Value (Val.F64); + when others => + raise Internal_Error; -- FIXME + end case; + end Value_To_Iir_Value; + + procedure Iir_Value_To_Value (Src : Iir_Value_Literal_Acc; + Dst : out Value_Union) is + begin + case Src.Kind is + when Iir_Value_B1 => + Dst.B1 := Src.B1; + when Iir_Value_E32 => + Dst.E32 := Src.E32; + when Iir_Value_I64 => + Dst.I64 := Src.I64; + when Iir_Value_F64 => + Dst.F64 := Src.F64; + when others => + raise Internal_Error; -- FIXME + end case; + end Iir_Value_To_Value; + + type Read_Signal_Flag_Enum is + (Read_Signal_Event, + Read_Signal_Active, + -- In order to reuse the same code (that returns immediately if the + -- attribute is true), we use not driving. + Read_Signal_Not_Driving); + + function Read_Signal_Flag (Lit: Iir_Value_Literal_Acc; + Kind : Read_Signal_Flag_Enum) + return Boolean + is + begin + case Lit.Kind is + when Iir_Value_Array => + for I in Lit.Val_Array.V'Range loop + if Read_Signal_Flag (Lit.Val_Array.V (I), Kind) then + return True; + end if; + end loop; + return False; + when Iir_Value_Record => + for I in Lit.Val_Record.V'Range loop + if Read_Signal_Flag (Lit.Val_Record.V (I), Kind) then + return True; + end if; + end loop; + return False; + when Iir_Value_Signal => + case Kind is + when Read_Signal_Event => + return Lit.Sig.Event; + when Read_Signal_Active => + return Lit.Sig.Active; + when Read_Signal_Not_Driving => + if Grt.Signals.Ghdl_Signal_Driving (Lit.Sig) = True then + return False; + else + return True; + end if; + end case; + when others => + raise Internal_Error; + end case; + end Read_Signal_Flag; + + function Execute_Event_Attribute (Lit: Iir_Value_Literal_Acc) + return Boolean is + begin + return Read_Signal_Flag (Lit, Read_Signal_Event); + end Execute_Event_Attribute; + + function Execute_Active_Attribute (Lit: Iir_Value_Literal_Acc) + return Boolean is + begin + return Read_Signal_Flag (Lit, Read_Signal_Active); + end Execute_Active_Attribute; + + function Execute_Driving_Attribute (Lit: Iir_Value_Literal_Acc) + return Boolean is + begin + return not Read_Signal_Flag (Lit, Read_Signal_Not_Driving); + end Execute_Driving_Attribute; + + type Read_Signal_Value_Enum is + (Read_Signal_Last_Value, + + -- For conversion functions. + Read_Signal_Driving_Value, + Read_Signal_Effective_Value, + + -- 'Driving_Value + Read_Signal_Driver_Value); + + function Execute_Read_Signal_Value (Sig: Iir_Value_Literal_Acc; + Attr : Read_Signal_Value_Enum) + return Iir_Value_Literal_Acc + is + Res: Iir_Value_Literal_Acc; + begin + case Sig.Kind is + when Iir_Value_Array => + Res := Copy_Array_Bound (Sig); + for I in Sig.Val_Array.V'Range loop + Res.Val_Array.V (I) := + Execute_Read_Signal_Value (Sig.Val_Array.V (I), Attr); + end loop; + return Res; + when Iir_Value_Record => + Res := Create_Record_Value (Sig.Val_Record.Len); + for I in Sig.Val_Record.V'Range loop + Res.Val_Record.V (I) := + Execute_Read_Signal_Value (Sig.Val_Record.V (I), Attr); + end loop; + return Res; + when Iir_Value_Signal => + case Attr is + when Read_Signal_Last_Value => + return Value_To_Iir_Value + (Sig.Sig.Mode, Sig.Sig.Last_Value); + when Read_Signal_Driver_Value => + case Sig.Sig.Mode is + when Mode_F64 => + return Create_F64_Value + (Grt.Signals.Ghdl_Signal_Driving_Value_F64 + (Sig.Sig)); + when Mode_I64 => + return Create_I64_Value + (Grt.Signals.Ghdl_Signal_Driving_Value_I64 + (Sig.Sig)); + when Mode_E32 => + return Create_E32_Value + (Grt.Signals.Ghdl_Signal_Driving_Value_E32 + (Sig.Sig)); + when Mode_B1 => + return Create_B1_Value + (Grt.Signals.Ghdl_Signal_Driving_Value_B1 + (Sig.Sig)); + when others => + raise Internal_Error; + end case; + when Read_Signal_Effective_Value => + return Value_To_Iir_Value + (Sig.Sig.Mode, Sig.Sig.Value); + when Read_Signal_Driving_Value => + return Value_To_Iir_Value + (Sig.Sig.Mode, Sig.Sig.Driving_Value); + end case; + when others => + raise Internal_Error; + end case; + end Execute_Read_Signal_Value; + + type Write_Signal_Enum is + (Write_Signal_Driving_Value, + Write_Signal_Effective_Value); + + procedure Execute_Write_Signal (Sig: Iir_Value_Literal_Acc; + Val : Iir_Value_Literal_Acc; + Attr : Write_Signal_Enum) is + begin + case Sig.Kind is + when Iir_Value_Array => + pragma Assert (Val.Kind = Iir_Value_Array); + pragma Assert (Sig.Val_Array.Len = Val.Val_Array.Len); + for I in Sig.Val_Array.V'Range loop + Execute_Write_Signal + (Sig.Val_Array.V (I), Val.Val_Array.V (I), Attr); + end loop; + when Iir_Value_Record => + pragma Assert (Val.Kind = Iir_Value_Record); + pragma Assert (Sig.Val_Record.Len = Val.Val_Record.Len); + for I in Sig.Val_Record.V'Range loop + Execute_Write_Signal + (Sig.Val_Record.V (I), Val.Val_Record.V (I), Attr); + end loop; + when Iir_Value_Signal => + pragma Assert (Val.Kind in Iir_Value_Scalars); + case Attr is + when Write_Signal_Driving_Value => + Iir_Value_To_Value (Val, Sig.Sig.Driving_Value); + when Write_Signal_Effective_Value => + Iir_Value_To_Value (Val, Sig.Sig.Value); + end case; + when others => + raise Internal_Error; + end case; + end Execute_Write_Signal; + + function Execute_Last_Value_Attribute (Indirect: Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + return Execute_Read_Signal_Value (Indirect, Read_Signal_Last_Value); + end Execute_Last_Value_Attribute; + + function Execute_Driving_Value_Attribute (Indirect: Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + return Execute_Read_Signal_Value (Indirect, Read_Signal_Driver_Value); + end Execute_Driving_Value_Attribute; + + type Signal_Read_Last_Type is + (Read_Last_Event, + Read_Last_Active); + + -- Return the Last_Event absolute time. + function Execute_Read_Signal_Last (Indirect: Iir_Value_Literal_Acc; + Kind : Signal_Read_Last_Type) + return Ghdl_I64 + is + Res: Ghdl_I64; + begin + case Indirect.Kind is + when Iir_Value_Array => + Res := Ghdl_I64'First; + for I in Indirect.Val_Array.V'Range loop + Res := Ghdl_I64'Max + (Res, Execute_Read_Signal_Last (Indirect.Val_Array.V (I), + Kind)); + end loop; + return Res; + when Iir_Value_Signal => + case Kind is + when Read_Last_Event => + return Ghdl_I64 (Indirect.Sig.Last_Event); + when Read_Last_Active => + return Ghdl_I64 (Indirect.Sig.Last_Active); + end case; + when others => + raise Internal_Error; + end case; + end Execute_Read_Signal_Last; + + function Execute_Last_Event_Attribute (Indirect: Iir_Value_Literal_Acc) + return Ghdl_I64 is + begin + return Execute_Read_Signal_Last (Indirect, Read_Last_Event); + end Execute_Last_Event_Attribute; + + function Execute_Last_Active_Attribute (Indirect: Iir_Value_Literal_Acc) + return Ghdl_I64 is + begin + return Execute_Read_Signal_Last (Indirect, Read_Last_Active); + end Execute_Last_Active_Attribute; + + function Execute_Signal_Value (Indirect: Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc + is + Res: Iir_Value_Literal_Acc; + begin + case Indirect.Kind is + when Iir_Value_Array => + Res := Copy_Array_Bound (Indirect); + for I in Indirect.Val_Array.V'Range loop + Res.Val_Array.V (I) := + Execute_Signal_Value (Indirect.Val_Array.V (I)); + end loop; + return Res; + when Iir_Value_Record => + Res := Create_Record_Value (Indirect.Val_Record.Len); + for I in Indirect.Val_Record.V'Range loop + Res.Val_Record.V (I) := + Execute_Signal_Value (Indirect.Val_Record.V (I)); + end loop; + return Res; + when Iir_Value_Signal => + return Value_To_Iir_Value (Indirect.Sig.Mode, Indirect.Sig.Value); + when others => + raise Internal_Error; + end case; + end Execute_Signal_Value; + + procedure Assign_Value_To_Array_Signal + (Instance: Block_Instance_Acc; + Target: Iir_Value_Literal_Acc; + Transactions: Transaction_Type) + is + Sub_Trans : Transaction_Type (Transactions.Len); + begin + Sub_Trans.Stmt := Transactions.Stmt; + Sub_Trans.Reject := Transactions.Reject; + + for J in Target.Val_Array.V'Range loop + for K in Transactions.Els'Range loop + declare + T : Transaction_El_Type renames Transactions.Els (K); + S : Transaction_El_Type renames Sub_Trans.Els (K); + begin + S.After := T.After; + + if T.Value = null then + S.Value := null; + else + S.Value := T.Value.Val_Array.V (J); + end if; + end; + end loop; + + Assign_Value_To_Signal + (Instance, Target.Val_Array.V (J), Sub_Trans); + end loop; + end Assign_Value_To_Array_Signal; + + procedure Assign_Value_To_Record_Signal + (Instance: Block_Instance_Acc; + Target: Iir_Value_Literal_Acc; + Transactions: Transaction_Type) + is + Sub_Trans : Transaction_Type (Transactions.Len); + begin + Sub_Trans.Stmt := Transactions.Stmt; + Sub_Trans.Reject := Transactions.Reject; + + for J in Target.Val_Record.V'Range loop + for K in Transactions.Els'Range loop + declare + T : Transaction_El_Type renames Transactions.Els (K); + S : Transaction_El_Type renames Sub_Trans.Els (K); + begin + S.After := T.After; + + if T.Value = null then + S.Value := null; + else + S.Value := T.Value.Val_Record.V (J); + end if; + end; + end loop; + + Assign_Value_To_Signal + (Instance, Target.Val_Record.V (J), Sub_Trans); + end loop; + end Assign_Value_To_Record_Signal; + + procedure Assign_Value_To_Scalar_Signal + (Instance: Block_Instance_Acc; + Target: Iir_Value_Literal_Acc; + Transactions: Transaction_Type) + is + pragma Unreferenced (Instance); + use Grt.Signals; + begin + declare + El : Transaction_El_Type renames Transactions.Els (1); + begin + if El.Value = null then + Ghdl_Signal_Start_Assign_Null + (Target.Sig, Transactions.Reject, El.After); + if Transactions.Els'Last /= 1 then + raise Internal_Error; + end if; + return; + end if; + + -- FIXME: null transaction, check constraints. + case Iir_Value_Scalars (El.Value.Kind) is + when Iir_Value_B1 => + Ghdl_Signal_Start_Assign_B1 + (Target.Sig, Transactions.Reject, El.Value.B1, El.After); + when Iir_Value_E32 => + Ghdl_Signal_Start_Assign_E32 + (Target.Sig, Transactions.Reject, El.Value.E32, El.After); + when Iir_Value_I64 => + Ghdl_Signal_Start_Assign_I64 + (Target.Sig, Transactions.Reject, El.Value.I64, El.After); + when Iir_Value_F64 => + Ghdl_Signal_Start_Assign_F64 + (Target.Sig, Transactions.Reject, El.Value.F64, El.After); + end case; + end; + + for I in 2 .. Transactions.Els'Last loop + declare + El : Transaction_El_Type renames Transactions.Els (I); + begin + case Iir_Value_Scalars (El.Value.Kind) is + when Iir_Value_B1 => + Ghdl_Signal_Next_Assign_B1 + (Target.Sig, El.Value.B1, El.After); + when Iir_Value_E32 => + Ghdl_Signal_Next_Assign_E32 + (Target.Sig, El.Value.E32, El.After); + when Iir_Value_I64 => + Ghdl_Signal_Next_Assign_I64 + (Target.Sig, El.Value.I64, El.After); + when Iir_Value_F64 => + Ghdl_Signal_Next_Assign_F64 + (Target.Sig, El.Value.F64, El.After); + end case; + end; + end loop; + end Assign_Value_To_Scalar_Signal; + + procedure Assign_Value_To_Signal + (Instance: Block_Instance_Acc; + Target: Iir_Value_Literal_Acc; + Transaction: Transaction_Type) + is + begin + case Target.Kind is + when Iir_Value_Array => + Assign_Value_To_Array_Signal + (Instance, Target, Transaction); + when Iir_Value_Record => + Assign_Value_To_Record_Signal + (Instance, Target, Transaction); + when Iir_Value_Signal => + Assign_Value_To_Scalar_Signal + (Instance, Target, Transaction); + when Iir_Value_Scalars + | Iir_Value_Range + | Iir_Value_File + | Iir_Value_Access + | Iir_Value_Protected + | Iir_Value_Quantity + | Iir_Value_Terminal => + raise Internal_Error; + end case; + end Assign_Value_To_Signal; + + procedure Disconnect_Signal (Sig : Iir_Value_Literal_Acc) is + begin + case Sig.Kind is + when Iir_Value_Array => + for I in Sig.Val_Array.V'Range loop + Disconnect_Signal (Sig.Val_Array.V (I)); + end loop; + when Iir_Value_Record => + for I in Sig.Val_Array.V'Range loop + Disconnect_Signal (Sig.Val_Record.V (I)); + end loop; + when Iir_Value_Signal => + Grt.Signals.Ghdl_Signal_Disconnect (Sig.Sig); + when others => + raise Internal_Error; + end case; + end Disconnect_Signal; + + -- Call Ghdl_Process_Wait_Add_Sensitivity for each scalar subelement of + -- SIG. + procedure Wait_Add_Sensitivity (Sig: Iir_Value_Literal_Acc) + is + begin + case Sig.Kind is + when Iir_Value_Signal => + Grt.Processes.Ghdl_Process_Wait_Add_Sensitivity (Sig.Sig); + when Iir_Value_Array => + for I in Sig.Val_Array.V'Range loop + Wait_Add_Sensitivity (Sig.Val_Array.V (I)); + end loop; + when Iir_Value_Record => + for I in Sig.Val_Record.V'Range loop + Wait_Add_Sensitivity (Sig.Val_Record.V (I)); + end loop; + when others => + raise Internal_Error; + end case; + end Wait_Add_Sensitivity; + + -- Return true if the process should be suspended. + function Execute_Wait_Statement (Instance : Block_Instance_Acc; + Stmt: Iir_Wait_Statement) + return Boolean + is + Expr: Iir; + El : Iir; + List: Iir_List; + Res: Iir_Value_Literal_Acc; + Status : Boolean; + Marker : Mark_Type; + begin + if not Instance.In_Wait_Flag then + Mark (Marker, Expr_Pool); + + -- LRM93 8.1 + -- The execution of a wait statement causes the time expression to + -- be evaluated to determine the timeout interval. + Expr := Get_Timeout_Clause (Stmt); + if Expr /= Null_Iir then + Res := Execute_Expression (Instance, Expr); + Grt.Processes.Ghdl_Process_Wait_Set_Timeout (Std_Time (Res.I64)); + end if; + + -- LRM93 8.1 + -- The suspended process may also resume as a result of an event + -- occuring on any signal in the sensitivity set of the wait + -- statement. + List := Get_Sensitivity_List (Stmt); + if List /= Null_Iir_List then + for J in Natural loop + El := Get_Nth_Element (List, J); + exit when El = Null_Iir; + Wait_Add_Sensitivity (Execute_Name (Instance, El, True)); + end loop; + end if; + + -- LRM93 8.1 + -- It also causes the execution of the corresponding process + -- statement to be suspended. + Grt.Processes.Ghdl_Process_Wait_Wait; + Instance.In_Wait_Flag := True; + Release (Marker, Expr_Pool); + return True; + else + -- LRM93 8.1 + -- The suspended process will resume, at the latest, immediately + -- after the timeout interval has expired. + if not Grt.Processes.Ghdl_Process_Wait_Has_Timeout then + -- Compute the condition clause only if the timeout has not + -- expired. + + -- LRM93 8.1 + -- If such an event occurs, the condition in the condition clause + -- is evaluated. + -- + -- if no condition clause appears, the condition clause until true + -- is assumed. + Status := + Execute_Condition (Instance, Get_Condition_Clause (Stmt)); + if not Status then + -- LRM93 8.1 + -- If the value of the condition is FALSE, the process will + -- re-suspend. + -- Such re-suspension does not involve the recalculation of + -- the timeout interval. + Grt.Processes.Ghdl_Process_Wait_Wait; + return True; + end if; + end if; + + -- LRM93 8.1 + -- If the value of the condition is TRUE, the process will resume. + -- next statement. + Grt.Processes.Ghdl_Process_Wait_Close; + + Instance.In_Wait_Flag := False; + return False; + end if; + end Execute_Wait_Statement; + + function To_Instance_Acc is new Ada.Unchecked_Conversion + (System.Address, Grt.Stacks.Instance_Acc); + + procedure Process_Executer (Self : Grt.Stacks.Instance_Acc); + pragma Convention (C, Process_Executer); + + procedure Process_Executer (Self : Grt.Stacks.Instance_Acc) + is + function To_Process_State_Acc is new Ada.Unchecked_Conversion + (Grt.Stacks.Instance_Acc, Process_State_Acc); + + Process : Process_State_Acc renames + To_Process_State_Acc (Self); + begin + -- For debugger + Current_Process := Process; + + Instance_Pool := Process.Pool'Access; + + if Trace_Simulation then + Put (" run process: "); + Disp_Instance_Name (Process.Top_Instance); + Put_Line (" (" & Disp_Location (Process.Proc) & ")"); + end if; + + Execute_Sequential_Statements (Process); + + -- Sanity checks. + if not Is_Empty (Expr_Pool) then + raise Internal_Error; + end if; + + case Get_Kind (Process.Proc) is + when Iir_Kind_Sensitized_Process_Statement => + if Process.Instance.In_Wait_Flag then + raise Internal_Error; + end if; + if Process.Instance.Stmt = Null_Iir then + Process.Instance.Stmt := + Get_Sequential_Statement_Chain (Process.Proc); + end if; + when Iir_Kind_Process_Statement => + if not Process.Instance.In_Wait_Flag then + raise Internal_Error; + end if; + when others => + raise Internal_Error; + end case; + + Instance_Pool := null; + Current_Process := null; + end Process_Executer; + + type Resolver_Read_Mode is (Read_Port, Read_Driver); + + function Resolver_Read_Value (Sig : Iir_Value_Literal_Acc; + Mode : Resolver_Read_Mode; + Index : Ghdl_Index_Type) + return Iir_Value_Literal_Acc + is + use Grt.Signals; + Val : Ghdl_Value_Ptr; + Res : Iir_Value_Literal_Acc; + begin + case Sig.Kind is + when Iir_Value_Array => + Res := Copy_Array_Bound (Sig); + for I in Sig.Val_Array.V'Range loop + Res.Val_Array.V (I) := + Resolver_Read_Value (Sig.Val_Array.V (I), Mode, Index); + end loop; + when Iir_Value_Record => + Res := Create_Record_Value (Sig.Val_Record.Len); + for I in Sig.Val_Record.V'Range loop + Res.Val_Record.V (I) := + Resolver_Read_Value (Sig.Val_Record.V (I), Mode, Index); + end loop; + when Iir_Value_Signal => + case Mode is + when Read_Port => + Val := Ghdl_Signal_Read_Port (Sig.Sig, Index); + when Read_Driver => + Val := Ghdl_Signal_Read_Driver (Sig.Sig, Index); + end case; + Res := Value_To_Iir_Value (Sig.Sig.Mode, Val.all); + when others => + raise Internal_Error; + end case; + return Res; + end Resolver_Read_Value; + + procedure Resolution_Proc (Instance_Addr : System.Address; + Val : System.Address; + Bool_Vec : System.Address; + Vec_Len : Ghdl_Index_Type; + Nbr_Drv : Ghdl_Index_Type; + Nbr_Ports : Ghdl_Index_Type) + is + pragma Unreferenced (Val); + + Instance : Resolv_Instance_Type; + pragma Import (Ada, Instance); + for Instance'Address use Instance_Addr; + + type Bool_Array is array (1 .. Nbr_Drv) of Boolean; + Vec : Bool_Array; + pragma Import (Ada, Vec); + for Vec'Address use Bool_Vec; + Off : Iir_Index32; + + Arr : Iir_Value_Literal_Acc; + Arr_Type : constant Iir := + Get_Type (Get_Interface_Declaration_Chain (Instance.Func)); + + Res : Iir_Value_Literal_Acc; + + Len : constant Iir_Index32 := Iir_Index32 (Vec_Len + Nbr_Ports); + Instance_Mark, Expr_Mark : Mark_Type; + begin + pragma Assert (Instance_Pool = null); + Instance_Pool := Global_Pool'Access; + Mark (Instance_Mark, Instance_Pool.all); + Mark (Expr_Mark, Expr_Pool); + Current_Process := No_Process; + + Arr := Create_Array_Value (Len, 1); + Arr.Bounds.D (1) := Create_Bounds_From_Length + (Instance.Block, + Get_First_Element (Get_Index_Subtype_List (Arr_Type)), + Len); + + -- First ports + for I in 1 .. Nbr_Ports loop + Arr.Val_Array.V (Iir_Index32 (I)) := Resolver_Read_Value + (Instance.Sig, Read_Port, I - 1); + end loop; + + -- Then drivers. + Off := Iir_Index32 (Nbr_Ports) + 1; + for I in 1 .. Nbr_Drv loop + if Vec (I) then + Arr.Val_Array.V (Off) := Resolver_Read_Value + (Instance.Sig, Read_Driver, I - 1); + Off := Off + 1; + end if; + end loop; + + -- Call resolution function. + Res := Execute_Resolution_Function (Instance.Block, Instance.Func, Arr); + + -- Set driving value. + Execute_Write_Signal (Instance.Sig, Res, Write_Signal_Driving_Value); + + Release (Instance_Mark, Instance_Pool.all); + Release (Expr_Mark, Expr_Pool); + Instance_Pool := null; + end Resolution_Proc; + + type Convert_Mode is (Convert_In, Convert_Out); + + type Convert_Instance_Type is record + Mode : Convert_Mode; + Instance : Block_Instance_Acc; + Func : Iir; + Src : Iir_Value_Literal_Acc; + Dst : Iir_Value_Literal_Acc; + end record; + + type Convert_Instance_Acc is access Convert_Instance_Type; + + procedure Conversion_Proc (Data : System.Address) is + Conv : Convert_Instance_Type; + pragma Import (Ada, Conv); + for Conv'Address use Data; + + Src : Iir_Value_Literal_Acc; + Dst : Iir_Value_Literal_Acc; + + Expr_Mark : Mark_Type; + begin + pragma Assert (Instance_Pool = null); + Instance_Pool := Global_Pool'Access; + Mark (Expr_Mark, Expr_Pool); + Current_Process := No_Process; + + case Conv.Mode is + when Convert_In => + Src := Execute_Read_Signal_Value + (Conv.Src, Read_Signal_Effective_Value); + when Convert_Out => + Src := Execute_Read_Signal_Value + (Conv.Src, Read_Signal_Driving_Value); + end case; + + Dst := Execute_Assoc_Conversion (Conv.Instance, Conv.Func, Src); + + Check_Bounds (Conv.Dst, Dst, Conv.Func); + + case Conv.Mode is + when Convert_In => + Execute_Write_Signal (Conv.Dst, Dst, Write_Signal_Effective_Value); + when Convert_Out => + Execute_Write_Signal (Conv.Dst, Dst, Write_Signal_Driving_Value); + end case; + + Release (Expr_Mark, Expr_Pool); + Instance_Pool := null; + end Conversion_Proc; + + function Guard_Func (Data : System.Address) return Ghdl_B1 + is + Guard : Guard_Instance_Type; + pragma Import (Ada, Guard); + for Guard'Address use Data; + + Val : Boolean; + + Prev_Instance_Pool : Areapool_Acc; + begin + pragma Assert (Instance_Pool = null + or else Instance_Pool = Global_Pool'Access); + Prev_Instance_Pool := Instance_Pool; + + Instance_Pool := Global_Pool'Access; + Current_Process := No_Process; + + Val := Execute_Condition + (Guard.Instance, Get_Guard_Expression (Guard.Guard)); + + Instance_Pool := Prev_Instance_Pool; + + return Ghdl_B1'Val (Boolean'Pos (Val)); + end Guard_Func; + + -- Add a driver for signal designed by VAL (via index field) for instance + -- INSTANCE of process PROC. + -- FIXME: default value. + procedure Add_Source + (Instance: Block_Instance_Acc; Val: Iir_Value_Literal_Acc; Proc: Iir) + is + begin + case Val.Kind is + when Iir_Value_Signal => + if Proc = Null_Iir then + -- Can this happen ? + raise Internal_Error; + end if; + Grt.Signals.Ghdl_Process_Add_Driver (Val.Sig); + when Iir_Value_Array => + for I in Val.Val_Array.V'Range loop + Add_Source (Instance, Val.Val_Array.V (I), Proc); + end loop; + when Iir_Value_Record => + for I in Val.Val_Record.V'Range loop + Add_Source (Instance, Val.Val_Record.V (I), Proc); + end loop; + when others => + raise Internal_Error; + end case; + end Add_Source; + + -- Add drivers for process PROC. + -- Note: this is done recursively on the callees of PROC. + procedure Elaborate_Drivers (Instance: Block_Instance_Acc; Proc: Iir) + is + Driver_List: Iir_List; + El: Iir; + Val: Iir_Value_Literal_Acc; + Marker : Mark_Type; + begin + if Trace_Drivers then + Ada.Text_IO.Put ("Drivers for "); + Disp_Instance_Name (Instance); + Ada.Text_IO.Put_Line (": " & Disp_Node (Proc)); + end if; + + Driver_List := Trans_Analyzes.Extract_Drivers (Proc); + + -- Some processes have no driver list (assertion). + if Driver_List = Null_Iir_List then + return; + end if; + + for I in Natural loop + El := Get_Nth_Element (Driver_List, I); + exit when El = Null_Iir; + if Trace_Drivers then + Put_Line (' ' & Disp_Node (El)); + end if; + + Mark (Marker, Expr_Pool); + Val := Execute_Name (Instance, El, True); + Add_Source (Instance, Val, Proc); + Release (Marker, Expr_Pool); + end loop; + end Elaborate_Drivers; + + -- Call Ghdl_Process_Add_Sensitivity for each scalar subelement of + -- SIG. + procedure Process_Add_Sensitivity (Sig: Iir_Value_Literal_Acc) is + begin + case Sig.Kind is + when Iir_Value_Signal => + Grt.Processes.Ghdl_Process_Add_Sensitivity (Sig.Sig); + when Iir_Value_Array => + for I in Sig.Val_Array.V'Range loop + Process_Add_Sensitivity (Sig.Val_Array.V (I)); + end loop; + when Iir_Value_Record => + for I in Sig.Val_Record.V'Range loop + Process_Add_Sensitivity (Sig.Val_Record.V (I)); + end loop; + when others => + raise Internal_Error; + end case; + end Process_Add_Sensitivity; + + procedure Create_Processes + is + use Grt.Processes; + El : Iir; + Instance : Block_Instance_Acc; + Instance_Grt : Grt.Stacks.Instance_Acc; + begin + Processes_State := new Process_State_Array (1 .. Processes_Table.Last); + + for I in Processes_Table.First .. Processes_Table.Last loop + Instance := Processes_Table.Table (I); + El := Instance.Label; + + Instance_Pool := Processes_State (I).Pool'Access; + Instance.Stmt := Get_Sequential_Statement_Chain (El); + + Processes_State (I).Top_Instance := Instance; + Processes_State (I).Proc := El; + Processes_State (I).Instance := Instance; + + Current_Process := Processes_State (I)'Access; + Instance_Grt := To_Instance_Acc (Processes_State (I)'Address); + case Get_Kind (El) is + when Iir_Kind_Sensitized_Process_Statement => + if Get_Postponed_Flag (El) then + Ghdl_Postponed_Sensitized_Process_Register + (Instance_Grt, + Process_Executer'Access, + null, System.Null_Address); + else + Ghdl_Sensitized_Process_Register + (Instance_Grt, + Process_Executer'Access, + null, System.Null_Address); + end if; + + -- Register sensitivity. + declare + Sig_List : Iir_List; + Sig : Iir; + Marker : Mark_Type; + begin + Sig_List := Get_Sensitivity_List (El); + for J in Natural loop + Sig := Get_Nth_Element (Sig_List, J); + exit when Sig = Null_Iir; + Mark (Marker, Expr_Pool); + Process_Add_Sensitivity + (Execute_Name (Instance, Sig, True)); + Release (Marker, Expr_Pool); + end loop; + end; + + when Iir_Kind_Process_Statement => + if Get_Postponed_Flag (El) then + Ghdl_Postponed_Process_Register + (Instance_Grt, + Process_Executer'Access, + null, System.Null_Address); + else + Ghdl_Process_Register + (Instance_Grt, + Process_Executer'Access, + null, System.Null_Address); + end if; + + when others => + raise Internal_Error; + end case; + + -- LRM93 §12.4.4 Other Concurrent Statements + -- All other concurrent statements are either process + -- statements or are statements for which there is an + -- equivalent process statement. + -- Elaboration of a process statement proceeds as follows: + -- 1. The process declarative part is elaborated. + Elaborate_Declarative_Part + (Instance, Get_Declaration_Chain (El)); + + -- 2. The drivers required by the process statement + -- are created. + -- 3. The initial transaction defined by the default value + -- associated with each scalar signal driven by the + -- process statement is inserted into the corresponding + -- driver. + -- FIXME: do it for drivers in called subprograms too. + Elaborate_Drivers (Instance, El); + + if not Is_Empty (Expr_Pool) then + raise Internal_Error; + end if; + + -- Elaboration of all concurrent signal assignment + -- statements and concurrent assertion statements consists + -- of the construction of the equivalent process statement + -- followed by the elaboration of the equivalent process + -- statement. + -- [GHDL: this is done by canonicalize. ] + + -- FIXME: check passive statements, + -- check no wait statement in sensitized processes. + + Instance_Pool := null; + end loop; + + if Trace_Simulation then + Disp_Signals_Value; + end if; + end Create_Processes; + + -- Configuration for the whole design + Top_Config : Iir_Design_Unit; + + -- Elaborate the design + procedure Ghdl_Elaborate; + pragma Export (C, Ghdl_Elaborate, "__ghdl_ELABORATE"); + + procedure Set_Disconnection (Val : Iir_Value_Literal_Acc; + Time : Iir_Value_Time) + is + begin + case Val.Kind is + when Iir_Value_Signal => + Grt.Signals.Ghdl_Signal_Set_Disconnect (Val.Sig, Std_Time (Time)); + when Iir_Value_Record => + for I in Val.Val_Record.V'Range loop + Set_Disconnection (Val.Val_Record.V (I), Time); + end loop; + when Iir_Value_Array => + for I in Val.Val_Array.V'Range loop + Set_Disconnection (Val.Val_Array.V (I), Time); + end loop; + when others => + raise Internal_Error; + end case; + end Set_Disconnection; + + procedure Create_Disconnections is + begin + for I in Disconnection_Table.First .. Disconnection_Table.Last loop + declare + E : Disconnection_Entry renames Disconnection_Table.Table (I); + begin + Set_Disconnection (E.Sig, E.Time); + end; + end loop; + end Create_Disconnections; + + type Connect_Mode is (Connect_Source, Connect_Effective); + + -- Add a driving value PORT to signal SIG, ie: PORT is a source for SIG. + -- As a side effect, this connect the signal SIG with the port PORT. + -- PORT is the formal, while SIG is the actual. + procedure Connect (Sig: Iir_Value_Literal_Acc; + Port: Iir_Value_Literal_Acc; + Mode : Connect_Mode) + is + begin + case Sig.Kind is + when Iir_Value_Array => + if Port.Kind /= Sig.Kind then + raise Internal_Error; + end if; + + if Sig.Val_Array.Len /= Port.Val_Array.Len then + raise Internal_Error; + end if; + for I in Sig.Val_Array.V'Range loop + Connect (Sig.Val_Array.V (I), Port.Val_Array.V (I), Mode); + end loop; + return; + when Iir_Value_Record => + if Port.Kind /= Sig.Kind then + raise Internal_Error; + end if; + if Sig.Val_Record.Len /= Port.Val_Record.Len then + raise Internal_Error; + end if; + for I in Sig.Val_Record.V'Range loop + Connect (Sig.Val_Record.V (I), Port.Val_Record.V (I), Mode); + end loop; + return; + when Iir_Value_Signal => + case Port.Kind is + when Iir_Value_Signal => + -- Here, SIG and PORT are simple signals (not composite). + -- PORT is a source for SIG. + case Mode is + when Connect_Source => + Grt.Signals.Ghdl_Signal_Add_Source + (Sig.Sig, Port.Sig); + when Connect_Effective => + Grt.Signals.Ghdl_Signal_Effective_Value + (Port.Sig, Sig.Sig); + end case; + when Iir_Value_Access + | Iir_Value_File + | Iir_Value_Range + | Iir_Value_Scalars -- FIXME: by value + | Iir_Value_Record + | Iir_Value_Array + | Iir_Value_Protected + | Iir_Value_Quantity + | Iir_Value_Terminal => + -- These cannot be driving value for a signal. + raise Internal_Error; + end case; + when Iir_Value_E32 => + if Mode = Connect_Source then + raise Internal_Error; + end if; + Grt.Signals.Ghdl_Signal_Associate_E32 (Port.Sig, Sig.E32); + when Iir_Value_I64 => + if Mode = Connect_Source then + raise Internal_Error; + end if; + Grt.Signals.Ghdl_Signal_Associate_I64 (Port.Sig, Sig.I64); + when Iir_Value_B1 => + if Mode = Connect_Source then + raise Internal_Error; + end if; + Grt.Signals.Ghdl_Signal_Associate_B1 (Port.Sig, Sig.B1); + when others => + raise Internal_Error; + end case; + end Connect; + + function Get_Leftest_Signal (Val : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + case Val.Kind is + when Iir_Value_Signal => + return Val; + when Iir_Value_Array => + return Get_Leftest_Signal (Val.Val_Array.V (1)); + when Iir_Value_Record => + return Get_Leftest_Signal (Val.Val_Record.V (1)); + when others => + raise Internal_Error; + end case; + end Get_Leftest_Signal; + + procedure Add_Conversion (Conv : Convert_Instance_Acc) + is + Src_Left : Grt.Signals.Ghdl_Signal_Ptr; + Src_Len : Ghdl_Index_Type; + Dst_Left : Grt.Signals.Ghdl_Signal_Ptr; + Dst_Len : Ghdl_Index_Type; + begin + Conv.Src := Unshare_Bounds (Conv.Src, Instance_Pool); + Conv.Dst := Unshare_Bounds (Conv.Dst, Instance_Pool); + + Src_Left := Get_Leftest_Signal (Conv.Src).Sig; + Src_Len := Ghdl_Index_Type (Get_Nbr_Of_Scalars (Conv.Src)); + + Dst_Left := Get_Leftest_Signal (Conv.Dst).Sig; + Dst_Len := Ghdl_Index_Type (Get_Nbr_Of_Scalars (Conv.Dst)); + + case Conv.Mode is + when Convert_In => + Grt.Signals.Ghdl_Signal_In_Conversion (Conversion_Proc'Address, + Conv.all'Address, + Src_Left, Src_Len, + Dst_Left, Dst_Len); + when Convert_Out => + Grt.Signals.Ghdl_Signal_Out_Conversion (Conversion_Proc'Address, + Conv.all'Address, + Src_Left, Src_Len, + Dst_Left, Dst_Len); + end case; + end Add_Conversion; + + function Create_Shadow_Signal (Sig : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc + is + begin + case Sig.Kind is + when Iir_Value_Signal => + case Sig.Sig.Mode is + when Mode_I64 => + return Create_Signal_Value + (Grt.Signals.Ghdl_Create_Signal_I64 + (0, null, System.Null_Address)); + when Mode_B1 => + return Create_Signal_Value + (Grt.Signals.Ghdl_Create_Signal_B1 + (False, null, System.Null_Address)); + when Mode_E32 => + return Create_Signal_Value + (Grt.Signals.Ghdl_Create_Signal_E32 + (0, null, System.Null_Address)); + when Mode_F64 => + return Create_Signal_Value + (Grt.Signals.Ghdl_Create_Signal_F64 + (0.0, null, System.Null_Address)); + when Mode_E8 + | Mode_I32 => + raise Internal_Error; + end case; + when Iir_Value_Array => + declare + Res : Iir_Value_Literal_Acc; + begin + Res := Unshare_Bounds (Sig, Instance_Pool); + for I in Res.Val_Array.V'Range loop + Res.Val_Array.V (I) := + Create_Shadow_Signal (Sig.Val_Array.V (I)); + end loop; + return Res; + end; + when Iir_Value_Record => + declare + Res : Iir_Value_Literal_Acc; + begin + Res := Create_Record_Value + (Sig.Val_Record.Len, Instance_Pool); + for I in Res.Val_Record.V'Range loop + Res.Val_Record.V (I) := + Create_Shadow_Signal (Sig.Val_Record.V (I)); + end loop; + return Res; + end; + when Iir_Value_Scalars + | Iir_Value_Access + | Iir_Value_Range + | Iir_Value_Protected + | Iir_Value_Terminal + | Iir_Value_Quantity + | Iir_Value_File => + raise Internal_Error; + end case; + end Create_Shadow_Signal; + + procedure Set_Connect + (Formal_Instance : Block_Instance_Acc; + Formal_Expr : Iir_Value_Literal_Acc; + Local_Instance : Block_Instance_Acc; + Local_Expr : Iir_Value_Literal_Acc; + Assoc : Iir_Association_Element_By_Expression) + is + pragma Unreferenced (Formal_Instance); + Formal : constant Iir := Get_Formal (Assoc); + Inter : constant Iir := Get_Association_Interface (Assoc); + begin + if False and Trace_Elaboration then + Put ("connect formal "); + Put (Iir_Mode'Image (Get_Mode (Inter))); + Put (" "); + Disp_Iir_Value (Formal_Expr, Get_Type (Formal)); + Put (" with actual "); + Disp_Iir_Value (Local_Expr, Get_Type (Get_Actual (Assoc))); + New_Line; + end if; + + case Get_Mode (Inter) is + when Iir_Out_Mode + | Iir_Inout_Mode + | Iir_Buffer_Mode + | Iir_Linkage_Mode => + -- FORMAL_EXPR is a source for LOCAL_EXPR. + declare + Out_Conv : constant Iir := Get_Out_Conversion (Assoc); + Src : Iir_Value_Literal_Acc; + begin + if Out_Conv /= Null_Iir then + Src := Create_Shadow_Signal (Local_Expr); + Add_Conversion + (new Convert_Instance_Type' + (Mode => Convert_Out, + Instance => Local_Instance, + Func => Out_Conv, + Src => Formal_Expr, + Dst => Src)); + else + Src := Formal_Expr; + end if; + -- LRM93 §12.6.2 + -- A signal is said to be active [...] if one of its source + -- is active. + Connect (Local_Expr, Src, Connect_Source); + end; + + when Iir_In_Mode => + null; + when Iir_Unknown_Mode => + raise Internal_Error; + end case; + + case Get_Mode (Inter) is + when Iir_In_Mode + | Iir_Inout_Mode + | Iir_Buffer_Mode + | Iir_Linkage_Mode => + declare + In_Conv : constant Iir := Get_In_Conversion (Assoc); + Src : Iir_Value_Literal_Acc; + begin + if In_Conv /= Null_Iir then + Src := Create_Shadow_Signal (Formal_Expr); + Add_Conversion + (new Convert_Instance_Type' + (Mode => Convert_In, + Instance => Local_Instance, + Func => Get_Implementation (In_Conv), + Src => Local_Expr, + Dst => Src)); + else + Src := Local_Expr; + end if; + Connect (Src, Formal_Expr, Connect_Effective); + end; + when Iir_Out_Mode => + null; + when Iir_Unknown_Mode => + raise Internal_Error; + end case; + end Set_Connect; + + procedure Create_Connects is + begin + -- New signals may be created (because of conversions). + Instance_Pool := Global_Pool'Access; + + for I in Connect_Table.First .. Connect_Table.Last loop + declare + E : Connect_Entry renames Connect_Table.Table (I); + begin + Set_Connect (E.Formal_Instance, E.Formal, + E.Actual_Instance, E.Actual, + E.Assoc); + end; + end loop; + + Instance_Pool := null; + end Create_Connects; + + procedure Create_Guard_Signal + (Instance : Block_Instance_Acc; + Sig_Guard : Iir_Value_Literal_Acc; + Guard : Iir) + is + procedure Add_Guard_Sensitivity (Sig : Iir_Value_Literal_Acc) is + begin + case Sig.Kind is + when Iir_Value_Signal => + Grt.Signals.Ghdl_Signal_Guard_Dependence (Sig.Sig); + when Iir_Value_Array => + for I in Sig.Val_Array.V'Range loop + Add_Guard_Sensitivity (Sig.Val_Array.V (I)); + end loop; + when Iir_Value_Record => + for I in Sig.Val_Record.V'Range loop + Add_Guard_Sensitivity (Sig.Val_Record.V (I)); + end loop; + when others => + raise Internal_Error; + end case; + end Add_Guard_Sensitivity; + + Dep_List : Iir_List; + Dep : Iir; + Data : Guard_Instance_Acc; + begin + Data := new Guard_Instance_Type'(Instance => Instance, + Guard => Guard); + Sig_Guard.Sig := Grt.Signals.Ghdl_Signal_Create_Guard + (Data.all'Address, Guard_Func'Access); + Dep_List := Get_Guard_Sensitivity_List (Guard); + for I in Natural loop + Dep := Get_Nth_Element (Dep_List, I); + exit when Dep = Null_Iir; + Add_Guard_Sensitivity (Execute_Name (Instance, Dep, True)); + end loop; + + -- FIXME: free mem + end Create_Guard_Signal; + + procedure Create_Implicit_Signal (Sig : Iir_Value_Literal_Acc; + Time : Ghdl_I64; + Prefix : Iir_Value_Literal_Acc; + Kind : Signal_Type_Kind) + is + procedure Register_Prefix (Pfx : Iir_Value_Literal_Acc) is + begin + case Pfx.Kind is + when Iir_Value_Signal => + Grt.Signals.Ghdl_Signal_Attribute_Register_Prefix (Pfx.Sig); + when Iir_Value_Array => + for I in Pfx.Val_Array.V'Range loop + Register_Prefix (Pfx.Val_Array.V (I)); + end loop; + when Iir_Value_Record => + for I in Pfx.Val_Record.V'Range loop + Register_Prefix (Pfx.Val_Record.V (I)); + end loop; + when others => + raise Internal_Error; + end case; + end Register_Prefix; + begin + case Kind is + when Implicit_Stable => + Sig.Sig := Grt.Signals.Ghdl_Create_Stable_Signal (Std_Time (Time)); + when Implicit_Quiet => + Sig.Sig := Grt.Signals.Ghdl_Create_Quiet_Signal (Std_Time (Time)); + when Implicit_Transaction => + Sig.Sig := Grt.Signals.Ghdl_Create_Transaction_Signal; + when others => + raise Internal_Error; + end case; + Register_Prefix (Prefix); + end Create_Implicit_Signal; + + procedure Create_Delayed_Signal + (Sig : Iir_Value_Literal_Acc; Pfx : Iir_Value_Literal_Acc; Val : Std_Time) + is + begin + case Pfx.Kind is + when Iir_Value_Array => + for I in Sig.Val_Array.V'Range loop + Create_Delayed_Signal + (Sig.Val_Array.V (I), Pfx.Val_Array.V (I), Val); + end loop; + when Iir_Value_Record => + for I in Pfx.Val_Record.V'Range loop + Create_Delayed_Signal + (Sig.Val_Record.V (I), Pfx.Val_Array.V (I), Val); + end loop; + when Iir_Value_Signal => + Sig.Sig := Grt.Signals.Ghdl_Create_Delayed_Signal (Pfx.Sig, Val); + when others => + raise Internal_Error; + end case; + end Create_Delayed_Signal; + + -- Create a new signal, using DEFAULT as initial value. + -- Set its number. + procedure Create_User_Signal (Block: Block_Instance_Acc; + Signal: Iir; + Sig : Iir_Value_Literal_Acc; + Default : Iir_Value_Literal_Acc) + is + use Grt.Rtis; + + procedure Create_Signal (Lit: Iir_Value_Literal_Acc; + Sig : Iir_Value_Literal_Acc; + Sig_Type: Iir; + Already_Resolved : Boolean) + is + Sub_Resolved : Boolean := Already_Resolved; + Resolv_Func : Iir; + Resolv_Instance : Resolv_Instance_Acc; + begin + if not Already_Resolved + and then Get_Kind (Sig_Type) in Iir_Kinds_Subtype_Definition + then + Resolv_Func := Get_Resolution_Function (Sig_Type); + else + Resolv_Func := Null_Iir; + end if; + if Resolv_Func /= Null_Iir then + Sub_Resolved := True; + Resolv_Instance := new Resolv_Instance_Type' + (Func => Get_Named_Entity (Resolv_Func), + Block => Block, + Sig => Sig); + Grt.Signals.Ghdl_Signal_Create_Resolution + (Resolution_Proc'Access, + Resolv_Instance.all'Address, + System.Null_Address, + Ghdl_Index_Type (Get_Nbr_Of_Scalars (Lit))); + end if; + case Lit.Kind is + when Iir_Value_Array => + declare + Sig_El_Type : constant Iir := + Get_Element_Subtype (Get_Base_Type (Sig_Type)); + begin + for I in Lit.Val_Array.V'Range loop + Create_Signal (Lit.Val_Array.V (I), Sig.Val_Array.V (I), + Sig_El_Type, Sub_Resolved); + end loop; + end; + when Iir_Value_Record => + declare + El : Iir_Element_Declaration; + List : Iir_List; + begin + List := Get_Elements_Declaration_List + (Get_Base_Type (Sig_Type)); + for I in Lit.Val_Record.V'Range loop + El := Get_Nth_Element (List, Natural (I - 1)); + Create_Signal (Lit.Val_Record.V (I), Sig.Val_Record.V (I), + Get_Type (El), Sub_Resolved); + end loop; + end; + + when Iir_Value_I64 => + Sig.Sig := Grt.Signals.Ghdl_Create_Signal_I64 + (Lit.I64, null, System.Null_Address); + when Iir_Value_B1 => + Sig.Sig := Grt.Signals.Ghdl_Create_Signal_B1 + (Lit.B1, null, System.Null_Address); + when Iir_Value_E32 => + Sig.Sig := Grt.Signals.Ghdl_Create_Signal_E32 + (Lit.E32, null, System.Null_Address); + when Iir_Value_F64 => + Sig.Sig := Grt.Signals.Ghdl_Create_Signal_F64 + (Lit.F64, null, System.Null_Address); + + when Iir_Value_Signal + | Iir_Value_Range + | Iir_Value_File + | Iir_Value_Access + | Iir_Value_Protected + | Iir_Value_Quantity + | Iir_Value_Terminal => + raise Internal_Error; + end case; + end Create_Signal; + + Sig_Type: constant Iir := Get_Type (Signal); + Mode : Mode_Signal_Type; + Kind : Kind_Signal_Type; + + type Iir_Mode_To_Mode_Signal_Type is + array (Iir_Mode) of Mode_Signal_Type; + Iir_Mode_To_Mode_Signal : constant Iir_Mode_To_Mode_Signal_Type := + (Iir_Unknown_Mode => Mode_Signal, + Iir_Linkage_Mode => Mode_Linkage, + Iir_Buffer_Mode => Mode_Buffer, + Iir_Out_Mode => Mode_Out, + Iir_Inout_Mode => Mode_Inout, + Iir_In_Mode => Mode_In); + + type Iir_Kind_To_Kind_Signal_Type is + array (Iir_Signal_Kind) of Kind_Signal_Type; + Iir_Kind_To_Kind_Signal : constant Iir_Kind_To_Kind_Signal_Type := + (Iir_No_Signal_Kind => Kind_Signal_No, + Iir_Register_Kind => Kind_Signal_Register, + Iir_Bus_Kind => Kind_Signal_Bus); + begin + case Get_Kind (Signal) is + when Iir_Kind_Signal_Interface_Declaration => + Mode := Iir_Mode_To_Mode_Signal (Get_Mode (Signal)); + when Iir_Kind_Signal_Declaration => + Mode := Mode_Signal; + when others => + Error_Kind ("elaborate_signal", Signal); + end case; + + Kind := Iir_Kind_To_Kind_Signal (Get_Signal_Kind (Signal)); + + Grt.Signals.Ghdl_Signal_Set_Mode (Mode, Kind, True); + + Create_Signal (Default, Sig, Sig_Type, False); + end Create_User_Signal; + + procedure Create_Signals is + begin + for I in Signals_Table.First .. Signals_Table.Last loop + declare + E : Signal_Entry renames Signals_Table.Table (I); + begin + case E.Kind is + when Guard_Signal => + Create_Guard_Signal (E.Instance, E.Sig, E.Decl); + when Implicit_Stable | Implicit_Quiet | Implicit_Transaction => + Create_Implicit_Signal (E.Sig, E.Time, E.Prefix, E.Kind); + when Implicit_Delayed => + Create_Delayed_Signal (E.Sig, E.Prefix, Std_Time (E.Time)); + when User_Signal => + Create_User_Signal (E.Instance, E.Decl, E.Sig, E.Init); + end case; + end; + end loop; + end Create_Signals; + + procedure Ghdl_Elaborate + is + Entity: Iir_Entity_Declaration; + + -- Number of input ports of the top entity. + In_Signals: Natural; + El : Iir; + begin + Instance_Pool := Global_Pool'Access; + + Elaboration.Elaborate_Design (Top_Config); + Entity := Iirs_Utils.Get_Entity (Get_Library_Unit (Top_Config)); + + if not Is_Empty (Expr_Pool) then + raise Internal_Error; + end if; + + Instance_Pool := null; + + -- Be sure there is no IN ports in the top entity. + El := Get_Port_Chain (Entity); + In_Signals := 0; + while El /= Null_Iir loop + if Get_Mode (El) = Iir_In_Mode then + In_Signals := In_Signals + 1; + end if; + El := Get_Chain (El); + end loop; + + if In_Signals /= 0 then + Error_Msg ("top entity should not have inputs signals"); + -- raise Simulation_Error; + end if; + + if Disp_Stats then + Disp_Design_Stats; + end if; + + if Disp_Ams then + Simulation.AMS.Debugger.Disp_Characteristic_Expressions; + end if; + + -- There is no inputs. + -- All the simulation is done via time, so it must be displayed. + Disp_Time_Before_Values := True; + + -- Initialisation. + if Trace_Simulation then + Put_Line ("Initialisation:"); + end if; + + Create_Signals; + Create_Connects; + Create_Disconnections; + Create_Processes; + + if Disp_Tree then + Debugger.Disp_Instances_Tree; + end if; + + if Flag_Interractive then + Debug (Reason_Elab); + end if; + end Ghdl_Elaborate; + + procedure Simulation_Entity (Top_Conf : Iir_Design_Unit) is + begin + Top_Config := Top_Conf; + Grt.Processes.One_Stack := True; + + Grt.Errors.Error_Hook := Debug_Error'Access; + + if Flag_Interractive then + Debug (Reason_Start); + end if; + + Grt.Main.Run; + exception + when Debugger_Quit => + null; + when Simulation_Finished => + null; + end Simulation_Entity; + +end Simulation; diff --git a/src/simulate/simulation.ads b/src/simulate/simulation.ads new file mode 100644 index 000000000..b910b4306 --- /dev/null +++ b/src/simulate/simulation.ads @@ -0,0 +1,128 @@ +-- Interpreted simulation +-- Copyright (C) 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 GHDL; 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 Grt.Types; use Grt.Types; +with Iirs; use Iirs; +with Iir_Values; use Iir_Values; +with Elaboration; use Elaboration; +with Execution; use Execution; + +package Simulation is + Trace_Simulation : Boolean := False; + Disp_Tree : Boolean := False; + Disp_Stats : Boolean := False; + Disp_Ams : Boolean := False; + Flag_Debugger : Boolean := False; + Flag_Interractive : Boolean := False; + + type Resolv_Instance_Type is record + Func : Iir; + Block : Block_Instance_Acc; + Sig : Iir_Value_Literal_Acc; + end record; + type Resolv_Instance_Acc is access Resolv_Instance_Type; + + -- The resolution procedure for GRT. + procedure Resolution_Proc (Instance_Addr : System.Address; + Val : System.Address; + Bool_Vec : System.Address; + Vec_Len : Ghdl_Index_Type; + Nbr_Drv : Ghdl_Index_Type; + Nbr_Ports : Ghdl_Index_Type); + pragma Convention (C, Resolution_Proc); + + type Guard_Instance_Type is record + Instance : Block_Instance_Acc; + Guard : Iir; + end record; + + type Guard_Instance_Acc is access Guard_Instance_Type; + + function Guard_Func (Data : System.Address) return Ghdl_B1; + pragma Convention (C, Guard_Func); + + -- The entry point of the simulator. + procedure Simulation_Entity (Top_Conf : Iir_Design_Unit); + + type Process_State_Array is + array (Process_Index_Type range <>) of aliased Process_State_Type; + type Process_State_Array_Acc is access Process_State_Array; + + -- Array containing all processes. + Processes_State: Process_State_Array_Acc; + + function Execute_Signal_Value (Indirect: Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc; + + function Execute_Event_Attribute (Lit: Iir_Value_Literal_Acc) + return Boolean; + + function Execute_Active_Attribute (Lit: Iir_Value_Literal_Acc) + return Boolean; + function Execute_Driving_Attribute (Lit: Iir_Value_Literal_Acc) + return Boolean; + + function Execute_Last_Value_Attribute (Indirect: Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc; + function Execute_Driving_Value_Attribute (Indirect: Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc; + + -- Return the Last_Event absolute time. + function Execute_Last_Event_Attribute (Indirect: Iir_Value_Literal_Acc) + return Ghdl_I64; + function Execute_Last_Active_Attribute (Indirect: Iir_Value_Literal_Acc) + return Ghdl_I64; + + -- Type for a transaction: it contains the value, the absolute time at which + -- the transaction should occur and a pointer to the next transaction. + -- This constitute a simple linked list, the elements must be ordered + -- according to time. + type Transaction_El_Type is record + -- The value of the waveform element. + -- Can't be an array. + -- Life must be target. + Value: Iir_Value_Literal_Acc; + + -- After time at which the transaction should occur. + After : Grt.Types.Std_Time; + end record; + + type Transaction_Array is array (Natural range <>) of Transaction_El_Type; + + type Transaction_Type (Len : Natural) is record + -- Statement that created this transaction. Used to disp location + -- in case of error (constraint error). + Stmt: Iir; + + Reject : Std_Time; + + Els : Transaction_Array (1 .. Len); + end record; + + procedure Assign_Value_To_Signal (Instance: Block_Instance_Acc; + Target: Iir_Value_Literal_Acc; + Transaction: Transaction_Type); + + procedure Disconnect_Signal (Sig : Iir_Value_Literal_Acc); + + -- Return true if the process should be suspended. + function Execute_Wait_Statement (Instance : Block_Instance_Acc; + Stmt: Iir_Wait_Statement) + return Boolean; +end Simulation; |