aboutsummaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
authorTristan Gingold <tgingold@free.fr>2016-01-24 05:14:35 +0100
committerTristan Gingold <tgingold@free.fr>2016-01-24 05:14:35 +0100
commitc03fc9f45df59e35ba9fba8bcf9e933fbb1074b9 (patch)
tree67f83680a6544012cc5755068f43a1089d0d8d53 /src
parenta4de40e69bbc961554e432f08fc146e07091c3f7 (diff)
downloadghdl-c03fc9f45df59e35ba9fba8bcf9e933fbb1074b9.tar.gz
ghdl-c03fc9f45df59e35ba9fba8bcf9e933fbb1074b9.tar.bz2
ghdl-c03fc9f45df59e35ba9fba8bcf9e933fbb1074b9.zip
simul: fix various issues.
Diffstat (limited to 'src')
-rw-r--r--src/ghdldrv/ghdlsimul.adb2
-rw-r--r--src/grt/grt-disp_signals.adb7
-rw-r--r--src/vhdl/canon.adb2
-rw-r--r--src/vhdl/iirs_utils.adb5
-rw-r--r--src/vhdl/iirs_utils.ads3
-rw-r--r--src/vhdl/sem_expr.adb1
-rw-r--r--src/vhdl/simulate/debugger.adb161
-rw-r--r--src/vhdl/simulate/debugger.ads2
-rw-r--r--src/vhdl/simulate/elaboration.adb122
-rw-r--r--src/vhdl/simulate/elaboration.ads12
-rw-r--r--src/vhdl/simulate/execution.adb254
-rw-r--r--src/vhdl/simulate/iir_values.adb4
-rw-r--r--src/vhdl/simulate/iir_values.ads5
-rw-r--r--src/vhdl/simulate/simulation.adb45
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;