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 | |
| parent | a4de40e69bbc961554e432f08fc146e07091c3f7 (diff) | |
| download | ghdl-c03fc9f45df59e35ba9fba8bcf9e933fbb1074b9.tar.gz ghdl-c03fc9f45df59e35ba9fba8bcf9e933fbb1074b9.tar.bz2 ghdl-c03fc9f45df59e35ba9fba8bcf9e933fbb1074b9.zip | |
simul: fix various issues.
| -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; | 
