diff options
author | Tristan Gingold <tgingold@free.fr> | 2016-01-24 05:14:35 +0100 |
---|---|---|
committer | Tristan Gingold <tgingold@free.fr> | 2016-01-24 05:14:35 +0100 |
commit | c03fc9f45df59e35ba9fba8bcf9e933fbb1074b9 (patch) | |
tree | 67f83680a6544012cc5755068f43a1089d0d8d53 /src | |
parent | a4de40e69bbc961554e432f08fc146e07091c3f7 (diff) | |
download | ghdl-c03fc9f45df59e35ba9fba8bcf9e933fbb1074b9.tar.gz ghdl-c03fc9f45df59e35ba9fba8bcf9e933fbb1074b9.tar.bz2 ghdl-c03fc9f45df59e35ba9fba8bcf9e933fbb1074b9.zip |
simul: fix various issues.
Diffstat (limited to 'src')
-rw-r--r-- | src/ghdldrv/ghdlsimul.adb | 2 | ||||
-rw-r--r-- | src/grt/grt-disp_signals.adb | 7 | ||||
-rw-r--r-- | src/vhdl/canon.adb | 2 | ||||
-rw-r--r-- | src/vhdl/iirs_utils.adb | 5 | ||||
-rw-r--r-- | src/vhdl/iirs_utils.ads | 3 | ||||
-rw-r--r-- | src/vhdl/sem_expr.adb | 1 | ||||
-rw-r--r-- | src/vhdl/simulate/debugger.adb | 161 | ||||
-rw-r--r-- | src/vhdl/simulate/debugger.ads | 2 | ||||
-rw-r--r-- | src/vhdl/simulate/elaboration.adb | 122 | ||||
-rw-r--r-- | src/vhdl/simulate/elaboration.ads | 12 | ||||
-rw-r--r-- | src/vhdl/simulate/execution.adb | 254 | ||||
-rw-r--r-- | src/vhdl/simulate/iir_values.adb | 4 | ||||
-rw-r--r-- | src/vhdl/simulate/iir_values.ads | 5 | ||||
-rw-r--r-- | src/vhdl/simulate/simulation.adb | 45 |
14 files changed, 368 insertions, 257 deletions
diff --git a/src/ghdldrv/ghdlsimul.adb b/src/ghdldrv/ghdlsimul.adb index 89d9f271c..ff64fcf17 100644 --- a/src/ghdldrv/ghdlsimul.adb +++ b/src/ghdldrv/ghdlsimul.adb @@ -180,7 +180,7 @@ package body Ghdlsimul is function Decode_Option (Option : String) return Boolean is begin - if Option = "--debug" then + if Option = "--debug" or Option = "-g" then Simulation.Flag_Debugger := True; else return False; diff --git a/src/grt/grt-disp_signals.adb b/src/grt/grt-disp_signals.adb index 265ca7b2c..a9b613c60 100644 --- a/src/grt/grt-disp_signals.adb +++ b/src/grt/grt-disp_signals.adb @@ -527,8 +527,13 @@ package body Grt.Disp_Signals is Res_Status : Traverse_Result; pragma Unreferenced (Res_Status); + + Top : constant Rti_Context := Get_Top_Context; begin - Res_Status := Foreach_Block (Get_Top_Context); + if Top /= Null_Context then + Res_Status := Foreach_Block (Top); + end if; + if not Found then Put (Stream, "(unknown signal)"); end if; diff --git a/src/vhdl/canon.adb b/src/vhdl/canon.adb index 951a78d19..0e907835a 100644 --- a/src/vhdl/canon.adb +++ b/src/vhdl/canon.adb @@ -2319,7 +2319,7 @@ package body Canon is Index : Iir; begin for I in Natural loop - Index := Get_Nth_Element (Indexes, I); + Index := Get_Index_Type (Indexes, I); exit when Index = Null_Iir; Canon_Subtype_Indication_If_Anonymous (Index); end loop; diff --git a/src/vhdl/iirs_utils.adb b/src/vhdl/iirs_utils.adb index 189f0f371..cf12e556a 100644 --- a/src/vhdl/iirs_utils.adb +++ b/src/vhdl/iirs_utils.adb @@ -850,6 +850,11 @@ package body Iirs_Utils is return Get_Index_Type (Get_Index_Subtype_List (Array_Type), Idx); end Get_Index_Type; + function Get_Nbr_Dimensions (Array_Type : Iir) return Natural is + begin + return Get_Nbr_Elements (Get_Index_Subtype_List (Array_Type)); + end Get_Nbr_Dimensions; + function Get_Denoted_Type_Mark (Subtyp : Iir) return Iir is Type_Mark_Name : constant Iir := Get_Subtype_Type_Mark (Subtyp); diff --git a/src/vhdl/iirs_utils.ads b/src/vhdl/iirs_utils.ads index eabd68e01..d92f7aa63 100644 --- a/src/vhdl/iirs_utils.ads +++ b/src/vhdl/iirs_utils.ads @@ -175,6 +175,9 @@ package Iirs_Utils is -- Likewise but for array type or subtype ARRAY_TYPE. function Get_Index_Type (Array_Type : Iir; Idx : Natural) return Iir; + -- Number of dimensions (1..n) for ARRAY_TYPE. + function Get_Nbr_Dimensions (Array_Type : Iir) return Natural; + -- Return the type or subtype definition of the SUBTYP type mark. function Get_Denoted_Type_Mark (Subtyp : Iir) return Iir; diff --git a/src/vhdl/sem_expr.adb b/src/vhdl/sem_expr.adb index 5568905a5..88150b75d 100644 --- a/src/vhdl/sem_expr.adb +++ b/src/vhdl/sem_expr.adb @@ -3319,6 +3319,7 @@ package body Sem_Expr is (Info.Index_Subtype, Index_Subtype_Constraint); Set_Type_Staticness (Info.Index_Subtype, Choice_Staticness); Set_Expr_Staticness (Index_Subtype_Constraint, Choice_Staticness); + Set_Type (Index_Subtype_Constraint, Index_Type); -- LRM93 7.3.2.2 -- For an aggregate that has named associations, the leftmost and diff --git a/src/vhdl/simulate/debugger.adb b/src/vhdl/simulate/debugger.adb index c1d846008..209bffefa 100644 --- a/src/vhdl/simulate/debugger.adb +++ b/src/vhdl/simulate/debugger.adb @@ -190,7 +190,8 @@ package body Debugger is | Iir_Kind_For_Generate_Statement | Iir_Kind_Component_Instantiation_Statement | Iir_Kind_Procedure_Declaration - | Iir_Kinds_Process_Statement => + | Iir_Kinds_Process_Statement + | Iir_Kind_Package_Declaration => return Image_Identifier (Name); when Iir_Kind_Iterator_Declaration => return Image_Identifier (Get_Parent (Name)) & '(' @@ -444,7 +445,10 @@ package body Debugger is Disp_Instance_Signals_Of_Chain (Instance, Get_Declaration_Chain (Blk)); when Iir_Kind_Component_Instantiation_Statement => - null; + Disp_Instance_Name (Instance); + Put_Line (" [component]:"); + Disp_Instance_Signals_Of_Chain + (Instance, Get_Port_Chain (Instance.Stmt)); when Iir_Kinds_Process_Statement => null; when Iir_Kind_Iterator_Declaration => @@ -469,36 +473,52 @@ package body Debugger is 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; + 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_Object + (Instance : Block_Instance_Acc; Decl : Iir) is + begin + case Get_Kind (Decl) is + when Iir_Kind_Constant_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_Object_Alias_Declaration => + Put (Disp_Node (Decl)); + Put (" = "); + Disp_Value_Tab (Instance.Objects (Get_Info (Decl).Slot), 3); + when Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Signal_Declaration => + declare + Sig : Iir_Value_Literal_Acc; + begin + Sig := Instance.Objects (Get_Info (Decl).Slot); + Put (Disp_Node (Decl)); + Put (" = "); + Disp_Signal (Sig, Get_Type (Decl)); + New_Line; + end; + when Iir_Kind_Type_Declaration + | Iir_Kind_Anonymous_Type_Declaration + | Iir_Kind_Subtype_Declaration => + -- FIXME: disp ranges + null; + when others => + Error_Kind ("disp_declaration_object", Decl); + end case; + end Disp_Declaration_Object; + procedure Disp_Declaration_Objects (Instance : Block_Instance_Acc; Decl_Chain : Iir) is @@ -506,34 +526,7 @@ package body Debugger is 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_Interface_Variable_Declaration - | Iir_Kind_Interface_Constant_Declaration - | Iir_Kind_Interface_File_Declaration - | Iir_Kind_Object_Alias_Declaration => - Put (Disp_Node (El)); - Put (" = "); - Disp_Value_Tab (Instance.Objects (Get_Info (El).Slot), 3); - when Iir_Kind_Interface_Signal_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 others => - Error_Kind ("disp_declaration_objects", El); - end case; + Disp_Declaration_Object (Instance, El); El := Get_Chain (El); end loop; end Disp_Declaration_Objects; @@ -1129,6 +1122,7 @@ package body Debugger is Exec_State := Exec_Single_Step; Flag_Need_Debug := True; Command_Status := Status_Quit; + Cmd_Repeat := Step_Proc'Access; end Step_Proc; Break_Id : Name_Id; @@ -1396,9 +1390,29 @@ package body Debugger is procedure Info_Signals_Proc (Line : String) is pragma Unreferenced (Line); begin - Check_Current_Process; - Disp_Declared_Signals - (Current_Process.Proc, Current_Process.Top_Instance); + if False then + Check_Current_Process; + Disp_Declared_Signals + (Current_Process.Proc, Current_Process.Top_Instance); + elsif True then + for I in Signals_Table.First .. Signals_Table.Last loop + declare + S : Signal_Entry renames Signals_Table.Table (I); + begin + Disp_Instance_Name (S.Instance, False); + Put ('.'); + if S.Kind = User_Signal then + Put (Name_Table.Image (Get_Identifier (S.Decl))); + Disp_Value (S.Sig); + Disp_Value (S.Val); + else + Disp_Declaration_Object (S.Instance, S.Decl); + end if; + end; + end loop; + else + Disp_Signals_Value; + end if; end Info_Signals_Proc; type Handle_Scope_Type is access procedure (N : Iir); @@ -1502,9 +1516,17 @@ package body Debugger is 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); + declare + Header : constant Iir := Get_Block_Header (N); + begin + Open_Declarative_Region; + if Header /= Null_Iir then + Add_Declarations (Get_Generic_Chain (Header), False); + Add_Declarations (Get_Port_Chain (Header), False); + end if; + Add_Declarations (Get_Declaration_Chain (N), False); + Add_Declarations_Of_Concurrent_Statement (N); + end; when Iir_Kind_Generate_Statement_Body => Open_Declarative_Region; Add_Declarations (Get_Declaration_Chain (N), False); @@ -1574,6 +1596,7 @@ package body Debugger is Res : Iir_Value_Literal_Acc; P : Natural; Opt_Value : Boolean := False; + Opt_Name : Boolean := False; Marker : Mark_Type; begin -- Decode options: /v @@ -1583,6 +1606,9 @@ package body Debugger is if P + 2 < Line'Last and then Line (P .. P + 1) = "/v" then Opt_Value := True; P := P + 2; + elsif P + 2 < Line'Last and then Line (P .. P + 1) = "/n" then + Opt_Name := True; + P := P + 2; else exit; end if; @@ -1626,7 +1652,20 @@ package body Debugger is Mark (Marker, Expr_Pool); - Res := Execute_Expression (Dbg_Cur_Frame, Expr); + if Opt_Name then + case Get_Kind (Expr) is + when Iir_Kind_Simple_Name => + null; + when others => + Put_Line ("expression is not a name"); + Opt_Name := False; + end case; + end if; + if Opt_Name then + Res := Execute_Name (Dbg_Cur_Frame, Expr, True); + else + Res := Execute_Expression (Dbg_Cur_Frame, Expr); + end if; if Opt_Value then Disp_Value (Res); else diff --git a/src/vhdl/simulate/debugger.ads b/src/vhdl/simulate/debugger.ads index 5e8c7ac67..b6ba1dccf 100644 --- a/src/vhdl/simulate/debugger.ads +++ b/src/vhdl/simulate/debugger.ads @@ -54,8 +54,6 @@ package Debugger is -- 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; diff --git a/src/vhdl/simulate/elaboration.adb b/src/vhdl/simulate/elaboration.adb index b85b452aa..013a25fe3 100644 --- a/src/vhdl/simulate/elaboration.adb +++ b/src/vhdl/simulate/elaboration.adb @@ -25,7 +25,6 @@ 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 Grt.Types; use Grt.Types; with Simulation.AMS; use Simulation.AMS; @@ -236,7 +235,7 @@ package body Elaboration is Instance.Objects (Info.Slot) := Sig; Init := Execute_Signal_Init_Value (Instance, Get_Prefix (Signal)); - Init := Unshare_Bounds (Init, Global_Pool'Access); + Init := Unshare (Init, Global_Pool'Access); -- Create a full copy. Instance.Objects (Info.Slot + 1) := Init; Signals_Table.Append ((Kind => Implicit_Delayed, @@ -307,6 +306,9 @@ package body Elaboration is Library_Unit: Iir; begin Depend_List := Get_Dependence_List (Design_Unit); + if Depend_List = Null_Iir_List then + return; + end if; for I in Natural loop Design := Get_Nth_Element (Depend_List, I); @@ -315,7 +317,12 @@ package body Elaboration is -- 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); + if Get_Kind (Library_Unit) in Iir_Kinds_Denoting_Name then + Design := Get_Named_Entity (Library_Unit); + Library_Unit := Get_Library_Unit (Design); + else + Design := Get_Design_Unit (Library_Unit); + end if; else Library_Unit := Get_Library_Unit (Design); end if; @@ -432,7 +439,7 @@ package body Elaboration is -- 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) + (Block: Block_Instance_Acc; Decl: Iir; Init : Init_Value_Kind) return Iir_Value_Literal_Acc is Res : Iir_Value_Literal_Acc; @@ -447,35 +454,37 @@ package body Elaboration is | 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; + case Init is + when Init_Value_Default => + Bounds := Execute_Bounds (Block, Decl); + Res := Bounds.Left; + when Init_Value_Any => + 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 case; when Iir_Kind_Array_Subtype_Definition => Res := Create_Array_Bounds_From_Type (Block, Decl, True); declare - El : Iir_Value_Literal_Acc; + El_Type : constant Iir := Get_Element_Subtype (Decl); + El_Val : 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; + -- Aliases the elements, for speed. If modified, the + -- value will first be copied which will unalias it. + El_Val := Create_Value_For_Type (Block, El_Type, Init); + for I in 1 .. Res.Val_Array.Len loop + Res.Val_Array.V (I) := El_Val; end loop; end if; end; @@ -493,7 +502,7 @@ package body Elaboration is 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); + Create_Value_For_Type (Block, Get_Type (El), Init); end loop; end; when Iir_Kind_Access_Type_Definition @@ -632,21 +641,6 @@ package body Elaboration is 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 @@ -673,15 +667,19 @@ package body Elaboration is 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)), + (Execute_Expression (Instance, Get_Left_Limit (Rc)), + Execute_Expression (Instance, Get_Right_Limit (Rc)), Get_Direction (Rc)); + -- Check constraints. + if not Is_Null_Range (Val) then + Check_Constraints (Instance, Val.Left, Get_Type (Rc), Rc); + Check_Constraints (Instance, Val.Right, Get_Type (Rc), Rc); + end if; Instance.Objects (Range_Info.Slot) := Unshare (Val, Instance_Pool); end Elaborate_Range_Expression; procedure Elaborate_Range_Constraint - (Instance : Block_Instance_Acc; Rc: Iir) - is + (Instance : Block_Instance_Acc; Rc: Iir) is begin case Get_Kind (Rc) is when Iir_Kind_Range_Expression => @@ -957,17 +955,19 @@ package body Elaboration is -- 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; + if Value /= Null_Iir then + Val := Execute_Expression (Target_Instance, Value); + else + Val := Create_Value_For_Type + (Target_Instance, Get_Type (Inter), + Init_Value_Default); 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); + (Local_Instance, Get_Actual_Type (Assoc), Init_Value_Any); Last_Individual := Unshare (Val, Instance_Pool); Target_Instance.Objects (Get_Info (Inter).Slot) := @@ -1134,6 +1134,9 @@ package body Elaboration is if Get_Whole_Association_Flag (Assoc) and then Get_Collapse_Signal_Flag (Assoc) then + pragma Assert (Get_In_Conversion (Assoc) = Null_Iir); + pragma Assert (Get_Out_Conversion (Assoc) = Null_Iir); + pragma Assert (Is_Signal_Name (Get_Actual (Assoc))); declare Slot : constant Object_Slot_Type := Get_Info (Inter).Slot; @@ -1147,6 +1150,12 @@ package body Elaboration is Formal_Instance.Objects (Slot) := Unshare_Bounds (Actual_Sig, Global_Pool'Access); Formal_Instance.Objects (Slot + 1) := Init_Expr; + if Get_Mode (Inter) = Iir_Out_Mode then + Assign_Value_To_Object + (Formal_Instance, Init_Expr, Get_Type (Inter), + Elaborate_Default_Value (Formal_Instance, Inter), + Assoc); + end if; end; else if Get_Whole_Association_Flag (Assoc) then @@ -1169,7 +1178,7 @@ package body Elaboration is when Iir_Kind_Association_Element_By_Individual => Init_Expr := Create_Value_For_Type - (Formal_Instance, Get_Actual_Type (Assoc), False); + (Formal_Instance, Get_Actual_Type (Assoc), Init_Value_Any); Elaborate_Signal (Formal_Instance, Inter, Init_Expr); when others => @@ -1518,7 +1527,6 @@ package body Elaboration is 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; @@ -1613,7 +1621,8 @@ package body Elaboration is Val := Execute_Expression_With_Type (Instance, Default_Value, Get_Type (Decl)); else - Val := Create_Value_For_Type (Instance, Get_Type (Decl), True); + Val := Create_Value_For_Type + (Instance, Get_Type (Decl), Init_Value_Default); end if; return Val; end Elaborate_Default_Value; @@ -2177,7 +2186,8 @@ package body Elaboration is when Iir_Kind_Iterator_Declaration => Elaborate_Subtype_Indication_If_Anonymous (Instance, Get_Type (Decl)); - Val := Create_Value_For_Type (Instance, Get_Type (Decl), True); + Val := Create_Value_For_Type + (Instance, Get_Type (Decl), Init_Value_Default); Create_Object (Instance, Decl); Instance.Objects (Get_Info (Decl).Slot) := Unshare (Val, Instance_Pool); diff --git a/src/vhdl/simulate/elaboration.ads b/src/vhdl/simulate/elaboration.ads index ff8b2109f..d63702adf 100644 --- a/src/vhdl/simulate/elaboration.ads +++ b/src/vhdl/simulate/elaboration.ads @@ -105,9 +105,17 @@ package Elaboration is procedure Destroy_Iterator_Declaration (Instance : Block_Instance_Acc; Decl : Iir); - -- Create a value for type DECL. Initialize it if DEFAULT is true. + -- How are created scalar values for Create_Value_For_Type. + type Init_Value_Kind is + (-- Use the default value for the type (lefmost value). + Init_Value_Default, + + -- Undefined. The caller doesn't care as it will overwrite the value. + Init_Value_Any); + + -- Create a value for type DECL. function Create_Value_For_Type - (Block: Block_Instance_Acc; Decl: Iir; Default : Boolean) + (Block: Block_Instance_Acc; Decl: Iir; Init : Init_Value_Kind) return Iir_Value_Literal_Acc; -- LRM93 §12.3.1.3 Subtype Declarations diff --git a/src/vhdl/simulate/execution.adb b/src/vhdl/simulate/execution.adb index b19a7ddab..0cc3f2d07 100644 --- a/src/vhdl/simulate/execution.adb +++ b/src/vhdl/simulate/execution.adb @@ -1760,7 +1760,7 @@ package body Execution is High, Low : Iir_Value_Literal_Acc; begin A_Range := Execute_Bounds (Block, Expr); - if Is_Nul_Range (A_Range) then + if Is_Null_Range (A_Range) then return; end if; if A_Range.Dir = Iir_To then @@ -2358,20 +2358,90 @@ package body Execution is function Execute_Signal_Init_Value (Block : Block_Instance_Acc; Expr : Iir) return Iir_Value_Literal_Acc is - Base : constant Iir := Get_Object_Prefix (Expr); + Base : constant Iir := Get_Object_Prefix (Expr, False); 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 (Block, Info.Obj_Scope); - Base_Val := Bblk.Objects (Info.Slot + 1); + if Get_Kind (Base) = Iir_Kind_Object_Alias_Declaration then + Bblk := Get_Instance_By_Scope (Block, Info.Obj_Scope); + Base_Val := Execute_Signal_Init_Value (Bblk, Get_Name (Base)); + else + Bblk := Get_Instance_By_Scope (Block, Info.Obj_Scope); + Base_Val := Bblk.Objects (Info.Slot + 1); + end if; Execute_Name_With_Base (Block, Expr, Base_Val, Res, Is_Sig); pragma Assert (Is_Sig); return Res; end Execute_Signal_Init_Value; + -- Indexed element will be at Pfx.Val_Array.V (Pos + 1) + procedure Execute_Indexed_Name (Block: Block_Instance_Acc; + Expr: Iir; + Pfx : Iir_Value_Literal_Acc; + Pos : out Iir_Index32) + is + pragma Assert (Get_Kind (Expr) = Iir_Kind_Indexed_Name); + Index_List : constant Iir_List := Get_Index_List (Expr); + Nbr_Dimensions : constant Iir_Index32 := + Iir_Index32 (Get_Nbr_Elements (Index_List)); + Index: Iir; + Value: Iir_Value_Literal_Acc; + Off : Iir_Index32; + begin + 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; + end Execute_Indexed_Name; + + -- Indexed element will be at Pfx.Val_Array.V (Pos) + procedure Execute_Slice_Name (Prefix_Array: Iir_Value_Literal_Acc; + Srange : Iir_Value_Literal_Acc; + Low : out Iir_Index32; + High : out Iir_Index32; + Loc : Iir) + is + Index_Order : Order; + -- Lower and upper bounds of the slice. + begin + pragma Assert (Prefix_Array /= null); + + -- 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", Loc); + 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), Loc); + High := Get_Index_Offset + (Srange.Right, Prefix_Array.Bounds.D (1), Loc); + end if; + end Execute_Slice_Name; + procedure Execute_Name_With_Base (Block: Block_Instance_Acc; Expr: Iir; Base : Iir_Value_Literal_Acc; @@ -2400,18 +2470,14 @@ package body Execution is 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_Interface_Signal_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); + Is_Sig := Is_Signal_Object (Expr); + 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_Interface_Constant_Declaration | Iir_Kind_Constant_Declaration @@ -2436,77 +2502,27 @@ package body Execution is 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; + Pfx : Iir_Value_Literal_Acc; + Pos : 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. + Execute_Name_With_Base + (Block, Get_Prefix (Expr), Base, Pfx, Is_Sig); + Execute_Indexed_Name (Block, Expr, Pfx, Pos); + Res := Pfx.Val_Array.V (Pos + 1); 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; + (Block, Get_Prefix (Expr), Base, Prefix_Array, Is_Sig); - -- 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; + Srange := Execute_Bounds (Block, Get_Suffix (Expr)); + Execute_Slice_Name (Prefix_Array, Srange, Low, High, Expr); - -- 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 @@ -2992,7 +3008,7 @@ package body Execution is Res := Create_Value_For_Type (Block, Get_Type_Of_Subtype_Indication (Get_Subtype_Indication (Expr)), - True); + Init_Value_Default); Res := Unshare_Heap (Res); return Create_Access_Value (Res); @@ -3360,6 +3376,34 @@ package body Execution is end case; end Execute_Assoc_Conversion; + procedure Associate_By_Reference (Block : Block_Instance_Acc; + Formal : Iir; + Formal_Base : Iir_Value_Literal_Acc; + Actual : Iir_Value_Literal_Acc) + is + Prefix : constant Iir := Strip_Denoting_Name (Get_Prefix (Formal)); + Is_Sig : Boolean; + Pfx : Iir_Value_Literal_Acc; + Pos : Iir_Index32; + begin + if Get_Kind (Prefix) = Iir_Kind_Slice_Name then + -- That case is not handled correctly. + raise Program_Error; + end if; + Execute_Name_With_Base (Block, Prefix, Formal_Base, Pfx, Is_Sig); + + case Get_Kind (Formal) is + when Iir_Kind_Indexed_Name => + Execute_Indexed_Name (Block, Formal, Pfx, Pos); + Store (Pfx.Val_Array.V (Pos + 1), Actual); + when Iir_Kind_Selected_Element => + Pos := Get_Element_Position (Get_Selected_Element (Formal)); + Store (Pfx.Val_Record.V (Pos + 1), Actual); + when others => + Error_Kind ("associate_by_reference", Formal); + end case; + end Associate_By_Reference; + -- Establish correspondance for association list ASSOC_LIST from block -- instance OUT_BLOCK for subprogram of block SUBPRG_BLOCK. procedure Execute_Association @@ -3398,13 +3442,12 @@ package body Execution is 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_Interface_Signal_Declaration); + -- Directly create the whole value on the instance pool, as its + -- life is longer than the statement. Last_Individual := Create_Value_For_Type - (Out_Block, Get_Actual_Type (Assoc), False); - Last_Individual := Unshare (Last_Individual, Instance_Pool); - + (Out_Block, Get_Actual_Type (Assoc), Init_Value_Any); + Last_Individual := + Unshare (Last_Individual, Instance_Pool); Elaboration.Create_Object (Subprg_Block, Inter); Subprg_Block.Objects (Get_Info (Inter).Slot) := Last_Individual; goto Continue; @@ -3464,13 +3507,13 @@ package body Execution is -- 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); + (Out_Block, Get_Type (Formal), Init_Value_Default); 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); + (Out_Block, Get_Type (Formal), Init_Value_Default); end if; else if Get_Kind (Assoc) = @@ -3510,14 +3553,8 @@ package body Execution is 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; + Associate_By_Reference + (Subprg_Block, Formal, Last_Individual, Val); end if; << Continue >> null; @@ -4022,35 +4059,20 @@ package body Execution is (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; + Stmt: Iir) is 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; + for I in Target.Val_Array.V'Range loop + Assign_Value_To_Object (Instance, + Target.Val_Array.V (I), + Get_Element_Subtype (Target_Type), + Value.Val_Array.V (I), + Stmt); + end loop; end Assign_Array_Value_To_Object; procedure Assign_Record_Value_To_Object @@ -4094,7 +4116,7 @@ package body Execution is case Target.Kind is when Iir_Value_Array => Assign_Array_Value_To_Object - (Instance, Target, Target_Type, 1, Value, Stmt); + (Instance, Target, Target_Type, Value, Stmt); when Iir_Value_Record => Assign_Record_Value_To_Object (Instance, Target, Target_Type, Value, Stmt); @@ -4338,7 +4360,7 @@ package body Execution is Bounds := Execute_Bounds (Instance, Get_Type (Iterator)); Index := Instance.Objects (Get_Info (Iterator).Slot); Store (Index, Bounds.Left); - Is_Nul := Is_Nul_Range (Bounds); + Is_Nul := Is_Null_Range (Bounds); Release (Marker, Expr_Pool); if Is_Nul then diff --git a/src/vhdl/simulate/iir_values.adb b/src/vhdl/simulate/iir_values.adb index 4fadb51f9..fb0dab057 100644 --- a/src/vhdl/simulate/iir_values.adb +++ b/src/vhdl/simulate/iir_values.adb @@ -187,7 +187,7 @@ package body Iir_Values is end case; end Compare_Value; - function Is_Nul_Range (Arange : Iir_Value_Literal_Acc) return Boolean + function Is_Null_Range (Arange : Iir_Value_Literal_Acc) return Boolean is Cmp : Order; begin @@ -198,7 +198,7 @@ package body Iir_Values is when Iir_Downto => return Cmp = Less; end case; - end Is_Nul_Range; + end Is_Null_Range; procedure Increment (Val : Iir_Value_Literal_Acc) is begin diff --git a/src/vhdl/simulate/iir_values.ads b/src/vhdl/simulate/iir_values.ads index 699ab883a..67a431cea 100644 --- a/src/vhdl/simulate/iir_values.ads +++ b/src/vhdl/simulate/iir_values.ads @@ -263,8 +263,8 @@ package Iir_Values is -- 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; + -- Return TRUE iif ARANGE is a null range. + function Is_Null_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). @@ -352,4 +352,3 @@ package Iir_Values is -- 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/vhdl/simulate/simulation.adb b/src/vhdl/simulate/simulation.adb index 28f29d7a5..df4e6b082 100644 --- a/src/vhdl/simulate/simulation.adb +++ b/src/vhdl/simulate/simulation.adb @@ -267,6 +267,14 @@ package body Simulation is Kind)); end loop; return Res; + when Iir_Value_Record => + Res := Ghdl_I64'First; + for I in Indirect.Val_Record.V'Range loop + Res := Ghdl_I64'Max + (Res, Execute_Read_Signal_Last (Indirect.Val_Record.V (I), + Kind)); + end loop; + return Res; when Iir_Value_Signal => case Kind is when Read_Last_Event => @@ -1433,23 +1441,36 @@ package body Simulation is Pfx : Iir_Value_Literal_Acc; Time : Std_Time) is + Val_Ptr : Ghdl_Value_Ptr; 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), Val.Val_Array.V (I), - Pfx.Val_Array.V (I), Time); - end loop; - when Iir_Value_Record => - for I in Pfx.Val_Record.V'Range loop - Create_Delayed_Signal - (Sig.Val_Record.V (I), Val.Val_Record.V (I), - Pfx.Val_Array.V (I), Time); + when Iir_Value_Array => + for I in Sig.Val_Array.V'Range loop + Create_Delayed_Signal + (Sig.Val_Array.V (I), Val.Val_Array.V (I), + Pfx.Val_Array.V (I), Time); end loop; + when Iir_Value_Record => + for I in Pfx.Val_Record.V'Range loop + Create_Delayed_Signal + (Sig.Val_Record.V (I), Val.Val_Record.V (I), + Pfx.Val_Array.V (I), Time); + end loop; when Iir_Value_Signal => + case Val.Kind is + when Iir_Value_I64 => + Val_Ptr := To_Ghdl_Value_Ptr (Val.I64'Address); + when Iir_Value_E32 => + Val_Ptr := To_Ghdl_Value_Ptr (Val.E32'Address); + when Iir_Value_F64 => + Val_Ptr := To_Ghdl_Value_Ptr (Val.F64'Address); + when Iir_Value_B1 => + Val_Ptr := To_Ghdl_Value_Ptr (Val.B1'Address); + when others => + raise Internal_Error; + end case; Sig.Sig := Grt.Signals.Ghdl_Create_Delayed_Signal - (Pfx.Sig, To_Ghdl_Value_Ptr (Val.B1'Address), Time); + (Pfx.Sig, Val_Ptr, Time); when others => raise Internal_Error; end case; |