diff options
| -rw-r--r-- | configuration.adb | 38 | ||||
| -rw-r--r-- | configuration.ads | 6 | ||||
| -rw-r--r-- | evaluation.adb | 259 | ||||
| -rw-r--r-- | evaluation.ads | 12 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdlrun.adb | 10 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdlsimul.adb | 55 | ||||
| -rw-r--r-- | translate/grt/grt-signals.adb | 52 | ||||
| -rw-r--r-- | translate/grt/grt-signals.ads | 38 | ||||
| -rw-r--r-- | translate/trans_decls.ads | 9 | ||||
| -rw-r--r-- | translate/translation.adb | 313 |
10 files changed, 444 insertions, 348 deletions
diff --git a/configuration.adb b/configuration.adb index 7fdcfb0b0..43dbafd7b 100644 --- a/configuration.adb +++ b/configuration.adb @@ -21,6 +21,7 @@ with Std_Package; with Sem_Names; with Name_Table; use Name_Table; with Flags; +with Iirs_Utils; package body Configuration is procedure Add_Design_Concurrent_Stmts (Parent : Iir); @@ -572,4 +573,41 @@ package body Configuration is return Top; end Configure; + procedure Check_Entity_Declaration_Top (Entity : Iir_Entity_Declaration) + is + Has_Error : Boolean := False; + + procedure Error (Msg : String; Loc : Iir) is + begin + if not Has_Error then + Error_Msg_Elab + (Disp_Node (Entity) & " cannot be at the top of a design"); + Has_Error := True; + end if; + Error_Msg_Elab (Msg, Loc); + end Error; + + El : Iir; + begin + -- Check generics. + El := Get_Generic_Chain (Entity); + while El /= Null_Iir loop + if Get_Default_Value (El) = Null_Iir then + Error ("(" & Disp_Node (El) & " has no default value)", El); + end if; + El := Get_Chain (El); + end loop; + + -- Check port. + El := Get_Port_Chain (Entity); + while El /= Null_Iir loop + if not Iirs_Utils.Is_Fully_Constrained_Type (Get_Type (El)) + and then Get_Default_Value (El) = Null_Iir + then + Error ("(" & Disp_Node (El) + & " is unconstrained and has no default value)", El); + end if; + El := Get_Chain (El); + end loop; + end Check_Entity_Declaration_Top; end Configuration; diff --git a/configuration.ads b/configuration.ads index 9b5ea9b3e..0a19a23c2 100644 --- a/configuration.ads +++ b/configuration.ads @@ -46,4 +46,10 @@ package Configuration is Flag_Load_All_Design_Units : Boolean := True; Flag_Build_File_Dependence : Boolean := False; + + -- Check if ENTITY can be at the top of a hierarchy, ie: + -- ENTITY has no generics or all generics have a default expression + -- ENTITY has no ports or all ports type are constrained. + -- If not, emit a elab error message. + procedure Check_Entity_Declaration_Top (Entity : Iir_Entity_Declaration); end Configuration; diff --git a/evaluation.adb b/evaluation.adb index 084050039..f193d1c66 100644 --- a/evaluation.adb +++ b/evaluation.adb @@ -15,6 +15,7 @@ -- along with GHDL; see the file COPYING. If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. +with Ada.Unchecked_Deallocation; with Errorout; use Errorout; with Name_Table; use Name_Table; with Str_Table; @@ -1470,51 +1471,56 @@ package body Evaluation is return C = ' ' or C = NBSP or C = HT; end White; - UnitName : String(Val'range); + UnitName : String (Val'range); + Mult : Iir_Int64; Sep : Natural; Found_Unit : Boolean := false; Found_Real : Boolean := false; Unit : Iir := Get_Primary_Unit (Phys_Type); begin -- Separate string into numeric value and make lowercase unit. - for i in reverse Val'range loop - UnitName(i) := Ada.Characters.Handling.To_Lower (Val(i)); - if White(Val(i)) and Found_Unit then - Sep := i; + for I in reverse Val'range loop + UnitName (I) := Ada.Characters.Handling.To_Lower (Val (I)); + if White (Val (I)) and Found_Unit then + Sep := I; exit; else Found_Unit := true; end if; end loop; + -- Unit name is UnitName(Sep+1..Unit'Last) - for i in Val'first .. Sep loop - if Val(i) = '.' then + for I in Val'First .. Sep loop + if Val (I) = '.' then Found_Real := true; end if; end loop; + -- Chain down the units looking for matching one Unit := Get_Primary_Unit (Phys_Type); while Unit /= Null_Iir loop - exit when UnitName(Sep+1..UnitName'Last) = Image_Identifier(Unit); + exit when (UnitName (Sep + 1 .. UnitName'Last) + = Image_Identifier (Unit)); Unit := Get_Chain (Unit); end loop; if Unit = Null_Iir then - Error_Msg_Sem ("Unit """ & UnitName(Sep+1..UnitName'Last) + Error_Msg_Sem ("Unit """ & UnitName (Sep + 1 .. UnitName'Last) & """ not in physical type", Expr); return Null_Iir; end if; + + Mult := Get_Value (Get_Physical_Unit_Value (Unit)); if Found_Real then - return Build_Physical(Iir_Int64( - Iir_Fp64'value(Val(Val'first .. Sep)) * - Iir_Fp64(Get_Value (Get_Physical_Unit_Value - (Unit)))), Expr); + return Build_Physical + (Iir_Int64 (Iir_Fp64'Value (Val (Val'First .. Sep)) + * Iir_Fp64 (Mult)), + Expr); else - return Build_Physical(Iir_Int64'value(Val(Val'first .. Sep)) * - Get_Value (Get_Physical_Unit_Value(Unit)), Expr); + return Build_Physical + (Iir_Int64'Value (Val (Val'First .. Sep)) * Mult, Expr); end if; end Build_Physical_Value; - function Eval_Incdec (Expr : Iir; N : Iir_Int64) return Iir is P : Iir_Int64; @@ -1814,11 +1820,11 @@ package body Evaluation is -- what type are we converting the string to? Param_Type := Get_Base_Type (Get_Type (Expr)); declare - Value : constant String := Image_String_Lit(Param); + Value : constant String := Image_String_Lit (Param); begin case Get_Kind (Param_Type) is when Iir_Kind_Integer_Type_Definition => - return Build_Discrete(Iir_Int64'value(Value), Expr); + return Build_Discrete (Iir_Int64'Value (Value), Expr); when Iir_Kind_Enumeration_Type_Definition => return Build_Enumeration_Value (Value, Param_Type, Expr); @@ -2566,4 +2572,221 @@ package body Evaluation is return Compare_Eq; end Compare_String_Literals; + function Get_Path_Instance_Name_Suffix (Attr : Iir) + return Path_Instance_Name_Type + is + -- Current path for name attributes. + Path_Str : String_Acc := null; + Path_Maxlen : Natural := 0; + Path_Len : Natural; + Path_Instance : Iir; + + procedure Deallocate is new Ada.Unchecked_Deallocation + (Name => String_Acc, Object => String); + + procedure Path_Reset is + begin + Path_Len := 0; + Path_Instance := Null_Iir; + if Path_Maxlen = 0 then + Path_Maxlen := 256; + Path_Str := new String (1 .. Path_Maxlen); + end if; + end Path_Reset; + + procedure Path_Add (Str : String) + is + N_Len : Natural; + N_Path : String_Acc; + begin + N_Len := Path_Maxlen; + loop + exit when Path_Len + Str'Length <= N_Len; + N_Len := N_Len * 2; + end loop; + if N_Len /= Path_Maxlen then + N_Path := new String (1 .. N_Len); + N_Path (1 .. Path_Len) := Path_Str (1 .. Path_Len); + Deallocate (Path_Str); + Path_Str := N_Path; + Path_Maxlen := N_Len; + end if; + Path_Str (Path_Len + 1 .. Path_Len + Str'Length) := Str; + Path_Len := Path_Len + Str'Length; + end Path_Add; + + procedure Path_Add_Type_Name (Atype : Iir) + is + Adecl : Iir; + begin + Adecl := Get_Type_Declarator (Atype); + Image (Get_Identifier (Adecl)); + Path_Add (Name_Buffer (1 .. Name_Length)); + end Path_Add_Type_Name; + + procedure Path_Add_Signature (Subprg : Iir) + is + Chain : Iir; + begin + Path_Add ("["); + Chain := Get_Interface_Declaration_Chain (Subprg); + while Chain /= Null_Iir loop + Path_Add_Type_Name (Get_Type (Chain)); + Chain := Get_Chain (Chain); + if Chain /= Null_Iir then + Path_Add (","); + end if; + end loop; + + case Get_Kind (Subprg) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Implicit_Function_Declaration => + Path_Add (" return "); + Path_Add_Type_Name (Get_Return_Type (Subprg)); + when others => + null; + end case; + Path_Add ("]"); + end Path_Add_Signature; + + procedure Path_Add_Name (N : Iir) is + begin + Eval_Simple_Name (Get_Identifier (N)); + if Name_Buffer (1) /= 'P' then + -- Skip anonymous processes. + Path_Add (Name_Buffer (1 .. Name_Length)); + end if; + end Path_Add_Name; + + procedure Path_Add_Element (El : Iir; Is_Instance : Boolean) is + begin + -- LRM 14.1 + -- E'INSTANCE_NAME + -- There is one full path instance element for each component + -- instantiation, block statement, generate statemenent, process + -- statement, or subprogram body in the design hierarchy between + -- the top design entity and the named entity denoted by the + -- prefix. + -- + -- E'PATH_NAME + -- There is one path instance element for each component + -- instantiation, block statement, generate statement, process + -- statement, or subprogram body in the design hierarchy between + -- the root design entity and the named entity denoted by the + -- prefix. + case Get_Kind (El) is + when Iir_Kind_Library_Declaration => + Path_Add (":"); + Path_Add_Name (El); + Path_Add (":"); + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Body => + Path_Add_Element + (Get_Library (Get_Design_File (Get_Design_Unit (El))), + Is_Instance); + Path_Add_Name (El); + Path_Add (":"); + when Iir_Kind_Entity_Declaration => + Path_Instance := El; + when Iir_Kind_Architecture_Declaration => + Path_Instance := El; + when Iir_Kind_Design_Unit => + Path_Add_Element (Get_Library_Unit (El), Is_Instance); + when Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement + | Iir_Kind_Block_Statement => + Path_Add_Element (Get_Parent (El), Is_Instance); + Path_Add_Name (El); + Path_Add (":"); + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + Path_Add_Element (Get_Parent (El), Is_Instance); + Path_Add_Name (El); + if Flags.Vhdl_Std >= Vhdl_02 then + -- Add signature. + Path_Add_Signature (El); + end if; + Path_Add (":"); + when Iir_Kind_Procedure_Body => + Path_Add_Element (Get_Subprogram_Specification (El), + Is_Instance); + when Iir_Kind_Generate_Statement => + declare + Scheme : Iir; + begin + Scheme := Get_Generation_Scheme (El); + if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then + Path_Instance := El; + else + Path_Add_Element (Get_Parent (El), Is_Instance); + Path_Add_Name (El); + Path_Add (":"); + end if; + end; + when Iir_Kinds_Sequential_Statement => + Path_Add_Element (Get_Parent (El), Is_Instance); + when others => + Error_Kind ("path_add_element", El); + end case; + end Path_Add_Element; + + Prefix : constant Iir := Get_Prefix (Attr); + Is_Instance : constant Boolean := + Get_Kind (Attr) = Iir_Kind_Instance_Name_Attribute; + begin + Path_Reset; + + -- LRM 14.1 + -- E'PATH_NAME + -- The local item name in E'PATH_NAME equals E'SIMPLE_NAME, unless + -- E denotes a library, package, subprogram or label. In this + -- latter case, the package based path or instance based path, + -- as appropriate, will not contain a local item name. + -- + -- E'INSTANCE_NAME + -- The local item name in E'INSTANCE_NAME equals E'SIMPLE_NAME, + -- unless E denotes a library, package, subprogram, or label. In + -- this latter case, the package based path or full instance based + -- path, as appropriate, will not contain a local item name. + case Get_Kind (Prefix) is + when Iir_Kind_Constant_Declaration + | Iir_Kind_Constant_Interface_Declaration + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Variable_Interface_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Signal_Interface_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_File_Interface_Declaration + | Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration => + Path_Add_Element (Get_Parent (Prefix), Is_Instance); + Path_Add_Name (Prefix); + when Iir_Kind_Library_Declaration + | Iir_Kind_Design_Unit + | Iir_Kind_Package_Declaration + | Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kinds_Concurrent_Statement + | Iir_Kinds_Sequential_Statement => + Path_Add_Element (Prefix, Is_Instance); + when others => + Error_Kind ("get_path_instance_name_suffix", Prefix); + end case; + + declare + Result : constant Path_Instance_Name_Type := + (Len => Path_Len, + Path_Instance => Path_Instance, + Suffix => Path_Str (1 .. Path_Len)); + begin + Deallocate (Path_Str); + return Result; + end; + end Get_Path_Instance_Name_Suffix; + end Evaluation; diff --git a/evaluation.ads b/evaluation.ads index 7a4df00bb..86dd977b4 100644 --- a/evaluation.ads +++ b/evaluation.ads @@ -104,4 +104,16 @@ package Evaluation is -- Compare two string literals (of same length). type Compare_Type is (Compare_Lt, Compare_Eq, Compare_Gt); function Compare_String_Literals (L, R : Iir) return Compare_Type; + + -- Return the local part of 'Instance_Name or 'Path_Name. + type Path_Instance_Name_Type (Len : Natural) is record + -- The node before suffix (entity, architecture or generate iterator). + Path_Instance : Iir; + + -- The suffix + Suffix : String (1 .. Len); + end record; + + function Get_Path_Instance_Name_Suffix (Attr : Iir) + return Path_Instance_Name_Type; end Evaluation; diff --git a/translate/ghdldrv/ghdlrun.adb b/translate/ghdldrv/ghdlrun.adb index fb05df789..7dbce3ded 100644 --- a/translate/ghdldrv/ghdlrun.adb +++ b/translate/ghdldrv/ghdlrun.adb @@ -304,13 +304,10 @@ package body Ghdlrun is Def (Trans_Decls.Ghdl_Now, Grt.Types.Current_Time'Address); - Def (Trans_Decls.Ghdl_Signal_Active_Chain, - Grt.Signals.Ghdl_Signal_Active_Chain'Address); - Def (Trans_Decls.Ghdl_Process_Add_Driver, Grt.Signals.Ghdl_Process_Add_Driver'Address); - Def (Trans_Decls.Ghdl_Signal_Direct_Driver, - Grt.Signals.Ghdl_Signal_Direct_Driver'Address); + Def (Trans_Decls.Ghdl_Signal_Add_Direct_Driver, + Grt.Signals.Ghdl_Signal_Add_Direct_Driver'Address); Def (Trans_Decls.Ghdl_Signal_Add_Source, Grt.Signals.Ghdl_Signal_Add_Source'Address); @@ -366,6 +363,9 @@ package body Ghdlrun is Def (Trans_Decls.Ghdl_Signal_Start_Assign_Null, Grt.Signals.Ghdl_Signal_Start_Assign_Null'Address); + Def (Trans_Decls.Ghdl_Signal_Direct_Assign, + Grt.Signals.Ghdl_Signal_Direct_Assign'Address); + Def (Trans_Decls.Ghdl_Create_Signal_B2, Grt.Signals.Ghdl_Create_Signal_B2'Address); Def (Trans_Decls.Ghdl_Signal_Init_B2, diff --git a/translate/ghdldrv/ghdlsimul.adb b/translate/ghdldrv/ghdlsimul.adb index d2a7772c9..a3f20ae69 100644 --- a/translate/ghdldrv/ghdlsimul.adb +++ b/translate/ghdldrv/ghdlsimul.adb @@ -48,6 +48,9 @@ with Grtlink; package body Ghdlsimul is + -- FIXME: reuse simulation.top_config + Top_Conf : Iir; + procedure Compile_Init (Analyze_Only : Boolean) is begin if Analyze_Only then @@ -72,6 +75,11 @@ package body Ghdlsimul is procedure Compile_Elab (Cmd_Name : String; Args : Argument_List; Opt_Arg : out Natural) is + use Name_Table; + use Types; + + First_Id : Name_Id; + Sec_Id : Name_Id; begin Extract_Elab_Unit (Cmd_Name, Args, Opt_Arg); @@ -82,6 +90,31 @@ package body Ghdlsimul is -- This may happen (bad entity for example). raise Compilation_Error; end if; + + First_Id := Get_Identifier (Prim_Name.all); + if Sec_Name = null then + Sec_Id := Null_Identifier; + else + Sec_Id := Get_Identifier (Sec_Name.all); + end if; + Top_Conf := Configuration.Configure (First_Id, Sec_Id); + if Top_Conf = Null_Iir then + raise Compilation_Error; + end if; + + -- Check (and possibly abandon) if entity can be at the top of the + -- hierarchy. + declare + Conf_Unit : constant Iir := Get_Library_Unit (Top_Conf); + Arch : constant Iir := + Get_Block_Specification (Get_Block_Configuration (Conf_Unit)); + Entity : constant Iir := Get_Entity (Arch); + begin + Configuration.Check_Entity_Declaration_Top (Entity); + if Nbr_Errors > 0 then + raise Compilation_Error; + end if; + end; end Compile_Elab; -- Set options. @@ -114,6 +147,8 @@ package body Ghdlsimul is Simulation.Trace_Simulation := True; elsif Arg.all = "--trace-stmt" then Execution.Trace_Statements := True; + elsif Arg.all = "--stats" then + Simulation.Disp_Stats := True; elsif Arg.all = "-i" then Simulation.Flag_Interractive := True; else @@ -133,26 +168,8 @@ package body Ghdlsimul is end loop; end Set_Run_Options; - procedure Run - is - use Name_Table; - use Types; - - First_Id : Name_Id; - Sec_Id : Name_Id; - Top_Conf : Iir; + procedure Run is begin - First_Id := Get_Identifier (Prim_Name.all); - if Sec_Name = null then - Sec_Id := Null_Identifier; - else - Sec_Id := Get_Identifier (Sec_Name.all); - end if; - Top_Conf := Configuration.Configure (First_Id, Sec_Id); - if Top_Conf = Null_Iir then - raise Compilation_Error; - end if; - Grtlink.Flag_String := Flags.Flag_String; Simulation.Simulation_Entity (Top_Conf); diff --git a/translate/grt/grt-signals.adb b/translate/grt/grt-signals.adb index dfcda9694..8b8953efa 100644 --- a/translate/grt/grt-signals.adb +++ b/translate/grt/grt-signals.adb @@ -173,6 +173,7 @@ package body Grt.Signals is Has_Active => False, Sig_Kind => Sig_Kind, + Is_Direct_Active => False, Mode => Mode, Flags => (Propag => Propag_None, Is_Dumped => False, @@ -336,8 +337,8 @@ package body Grt.Signals is end if; end Ghdl_Process_Add_Driver; - procedure Ghdl_Signal_Direct_Driver (Sign : Ghdl_Signal_Ptr; - Drv : Ghdl_Value_Ptr) + procedure Ghdl_Signal_Add_Direct_Driver (Sign : Ghdl_Signal_Ptr; + Drv : Ghdl_Value_Ptr) is Trans : Transaction_Acc; Trans1 : Transaction_Acc; @@ -360,7 +361,7 @@ package body Grt.Signals is Val_Ptr => Drv); Sign.S.Drivers (Sign.S.Nbr_Drivers - 1).Last_Trans := Trans1; Trans.Next := Trans1; - end Ghdl_Signal_Direct_Driver; + end Ghdl_Signal_Add_Direct_Driver; procedure Append_Port (Targ : Ghdl_Signal_Ptr; Src : Ghdl_Signal_Ptr) is @@ -505,6 +506,32 @@ package body Grt.Signals is return null; end Get_Driver; + -- Return TRUE iff SIG has a future transaction for the current time, + -- ie iff SIG will be active in the next delta cycle. This is used to + -- recompute wether SIG must be in the active chain. SIG must be a user + -- signal. + function Has_Transaction_In_Next_Delta (Sig : Ghdl_Signal_Ptr) + return Boolean is + begin + if Sig.Is_Direct_Active then + return True; + end if; + + for I in 1 .. Sig.S.Nbr_Drivers loop + declare + Trans : constant Transaction_Acc := + Sig.S.Drivers (I - 1).First_Trans.Next; + begin + if Trans.Kind /= Trans_Direct + and then Trans.Time = Current_Time + then + return True; + end if; + end; + end loop; + return False; + end Has_Transaction_In_Next_Delta; + -- Unused but well-known signal which always terminate -- ghdl_signal_active_chain. -- As a consequence, every element of the chain has a link field set to @@ -707,7 +734,7 @@ package body Grt.Signals is -- the chain is simply linked), but that issue doesn't appear -- frequently. if Sign.Link /= null - and then Driver.First_Trans.Next.Time /= Current_Time + and then not Has_Transaction_In_Next_Delta (Sign) then if Ghdl_Signal_Active_Chain = Sign then -- At the head of the chain. @@ -767,6 +794,17 @@ package body Grt.Signals is Driver.Last_Trans := Trans; end Ghdl_Signal_Next_Assign; + procedure Ghdl_Signal_Direct_Assign (Sign : Ghdl_Signal_Ptr) is + begin + if Sign.Link = null then + Sign.Link := Grt.Threads.Atomic_Insert + (Ghdl_Signal_Active_Chain'access, Sign); + end if; + + -- Must be always set (as Sign.Link may be set by a regular driver). + Sign.Is_Direct_Active := True; + end Ghdl_Signal_Direct_Assign; + procedure Ghdl_Signal_Simple_Assign_Error (Sign : Ghdl_Signal_Ptr; File : Ghdl_C_String; Line : Ghdl_I32) @@ -2624,6 +2662,7 @@ package body Grt.Signals is Clear_List : Ghdl_Signal_Ptr := null; + -- Mark SIG as active and put it on Clear_List (if not already). procedure Mark_Active (Sig : Ghdl_Signal_Ptr); pragma Inline (Mark_Active); @@ -3055,6 +3094,7 @@ package body Grt.Signals is -- 1) Reset active flag. Reset_Active_Flag; + -- For each active signals Sig := Ghdl_Signal_Active_Chain; Ghdl_Signal_Active_Chain := Signal_End; while Sig.S.Mode_Sig /= Mode_End loop @@ -3083,6 +3123,7 @@ package body Grt.Signals is when Net_One_Direct => Mark_Active (Sig); + Sig.Is_Direct_Active := False; Trans := Sig.S.Drivers (0).Last_Trans; Direct_Assign (Sig.Driving_Value, Trans.Val_Ptr, Sig.Mode); @@ -3092,6 +3133,7 @@ package body Grt.Signals is when Net_One_Resolved => -- This signal is active. Mark_Active (Sig); + Sig.Is_Direct_Active := False; for J in 1 .. Sig.S.Nbr_Drivers loop Trans := Sig.S.Drivers (J - 1).First_Trans.Next; @@ -3112,6 +3154,7 @@ package body Grt.Signals is Internal_Error ("update_signals: no_signal_net"); when others => + Sig.Is_Direct_Active := False; if not Propagation.Table (Sig.Net).Updated then Propagation.Table (Sig.Net).Updated := True; Run_Propagation (Sig.Net + 1); @@ -3324,6 +3367,7 @@ package body Grt.Signals is Event => False, Active => False, Has_Active => False, + Is_Direct_Active => False, Sig_Kind => Kind_Signal_No, Mode => Mode_B2, diff --git a/translate/grt/grt-signals.ads b/translate/grt/grt-signals.ads index eac47a782..875d8769f 100644 --- a/translate/grt/grt-signals.ads +++ b/translate/grt/grt-signals.ads @@ -275,18 +275,13 @@ package Grt.Signals is pragma Pack (Ghdl_Signal_Flags); type Ghdl_Signal is record - -- Fields known by ghdl. + -- Fields known by the compilers. Value : Value_Union; Driving_Value : Value_Union; Last_Value : Value_Union; Last_Event : Std_Time; Last_Active : Std_Time; - -- Chain of signals. - -- Used to build nets. - -- This is also the simply linked list of future active signals. - Link : Ghdl_Signal_Ptr; - Event : Boolean; Active : Boolean; -- If set, the activity of the signal is required by the user. @@ -295,6 +290,9 @@ package Grt.Signals is -- Internal fields. -- NOTE: keep above fields (components) in sync with translation. + -- If set, the signal has an active direct driver. + Is_Direct_Active : Boolean; + -- Kind of the signal (none, bus or register). Sig_Kind : Kind_Signal_Type; @@ -307,7 +305,12 @@ package Grt.Signals is -- Net of the signal. Net : Signal_Net_Type; - -- Chain of signals whose active flag was set. Used to clear it. + -- Chain of signals that will be active in the next delta-cycle. + -- (Also used to build nets). + Link : Ghdl_Signal_Ptr; + + -- Chain of signals whose active flag was set. Used to clear the active + -- flag at the end of the delta cycle. Alink : Ghdl_Signal_Ptr; -- Chain of signals that have a projected waveform in the real future. @@ -530,6 +533,8 @@ package Grt.Signals is File : Ghdl_C_String; Line : Ghdl_I32); + procedure Ghdl_Signal_Direct_Assign (Sign : Ghdl_Signal_Ptr); + procedure Ghdl_Signal_Set_Disconnect (Sign : Ghdl_Signal_Ptr; Time : Std_Time); @@ -652,9 +657,15 @@ package Grt.Signals is -- Add a driver to SIGN for the current process. procedure Ghdl_Process_Add_Driver (Sign : Ghdl_Signal_Ptr); - -- Add a direct driver for the current process. - procedure Ghdl_Signal_Direct_Driver (Sign : Ghdl_Signal_Ptr; - Drv : Ghdl_Value_Ptr); + -- Add a direct driver for the current process. This is an optimization + -- that could be used when a driver has no projected waveforms. + -- + -- Assignment using direct driver: + -- * the driver value is set + -- * put the signal on the ghdl_signal_active_chain, if the signal will + -- be active and if not already on the chain. + procedure Ghdl_Signal_Add_Direct_Driver (Sign : Ghdl_Signal_Ptr; + Drv : Ghdl_Value_Ptr); -- Used for connexions: -- SRC is a source for TARG. @@ -759,6 +770,9 @@ private pragma Export (C, Ghdl_Signal_Start_Assign_Null, "__ghdl_signal_start_assign_null"); + pragma Export (C, Ghdl_Signal_Direct_Assign, + "__ghdl_signal_direct_assign"); + pragma Export (C, Ghdl_Signal_Set_Disconnect, "__ghdl_signal_set_disconnect"); pragma Export (C, Ghdl_Signal_Disconnect, @@ -859,8 +873,8 @@ private pragma Export (C, Ghdl_Process_Add_Driver, "__ghdl_process_add_driver"); - pragma Export (C, Ghdl_Signal_Direct_Driver, - "__ghdl_signal_direct_driver"); + pragma Export (C, Ghdl_Signal_Add_Direct_Driver, + "__ghdl_signal_add_direct_driver"); pragma Export (C, Ghdl_Signal_Add_Source, "__ghdl_signal_add_source"); diff --git a/translate/trans_decls.ads b/translate/trans_decls.ads index eadba8bde..23bd6d9dc 100644 --- a/translate/trans_decls.ads +++ b/translate/trans_decls.ads @@ -49,8 +49,9 @@ package Trans_Decls is -- Register a driver for a process. Ghdl_Process_Add_Driver : O_Dnode; + Ghdl_Signal_Add_Direct_Driver : O_Dnode; - -- NOW variables. + -- NOW variable. Ghdl_Now : O_Dnode; -- Protected variables. @@ -64,6 +65,7 @@ package Trans_Decls is Ghdl_Signal_Driving : O_Dnode; + Ghdl_Signal_Direct_Assign : O_Dnode; Ghdl_Signal_Simple_Assign_Error : O_Dnode; Ghdl_Signal_Start_Assign_Error : O_Dnode; @@ -72,8 +74,6 @@ package Trans_Decls is Ghdl_Signal_Start_Assign_Null : O_Dnode; Ghdl_Signal_Next_Assign_Null : O_Dnode; - Ghdl_Signal_Direct_Driver : O_Dnode; - Ghdl_Create_Signal_E8 : O_Dnode; Ghdl_Signal_Init_E8 : O_Dnode; Ghdl_Signal_Simple_Assign_E8 : O_Dnode; @@ -138,9 +138,6 @@ package Trans_Decls is Ghdl_Signal_Read_Driver : O_Dnode; Ghdl_Signal_Read_Port : O_Dnode; - -- Chain of to be active signals. - Ghdl_Signal_Active_Chain : O_Dnode; - -- Signal attribute. Ghdl_Create_Stable_Signal : O_Dnode; Ghdl_Create_Quiet_Signal : O_Dnode; diff --git a/translate/translation.adb b/translate/translation.adb index 4be924a69..4c3360dee 100644 --- a/translate/translation.adb +++ b/translate/translation.adb @@ -147,7 +147,6 @@ package body Translation is Ghdl_Signal_Last_Value_Field : O_Fnode; Ghdl_Signal_Last_Event_Field : O_Fnode; Ghdl_Signal_Last_Active_Field : O_Fnode; - Ghdl_Signal_Active_Chain_Field : O_Fnode; Ghdl_Signal_Event_Field : O_Fnode; Ghdl_Signal_Active_Field : O_Fnode; Ghdl_Signal_Has_Active_Field : O_Fnode; @@ -21264,6 +21263,7 @@ package body Translation is is Targ_Sig : Mnode; If_Blk : O_If_Block; + Constr : O_Assoc_List; Cond : O_Dnode; Drv : Mnode; begin @@ -21300,25 +21300,14 @@ package body Translation is -- Put signal into active list (if not already in the list). -- FIXME: this is not thread-safe! - Start_If_Stmt - (If_Blk, - New_Dyadic_Op - (ON_And, - New_Obj_Value (Cond), - New_Compare_Op - (ON_Eq, - New_Value (Chap14.Get_Signal_Field - (Targ_Sig, Ghdl_Signal_Active_Chain_Field)), - New_Lit (New_Null_Access (Ghdl_Signal_Ptr)), - Ghdl_Bool_Type))); - New_Assign_Stmt - (Chap14.Get_Signal_Field (Targ_Sig, Ghdl_Signal_Active_Chain_Field), - New_Obj_Value (Ghdl_Signal_Active_Chain)); - New_Assign_Stmt - (New_Obj (Ghdl_Signal_Active_Chain), - New_Convert_Ov (New_Value (M2Lv (Targ_Sig)), - Ghdl_Signal_Ptr)); + Start_If_Stmt (If_Blk, New_Obj_Value (Cond)); + Start_Association (Constr, Ghdl_Signal_Direct_Assign); + New_Association (Constr, + New_Convert_Ov (New_Value (M2Lv (Targ_Sig)), + Ghdl_Signal_Ptr)); + New_Procedure_Call (Constr); Finish_If_Stmt (If_Blk); + Close_Temp; end Gen_Signal_Direct_Assign_Non_Composite; @@ -22590,7 +22579,7 @@ package body Translation is pragma Unreferenced (Targ_Type); Constr : O_Assoc_List; begin - Start_Association (Constr, Ghdl_Signal_Direct_Driver); + Start_Association (Constr, Ghdl_Signal_Add_Direct_Driver); New_Association (Constr, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); New_Association @@ -22662,7 +22651,7 @@ package body Translation is -- pragma Unreferenced (Sig_Type); -- Constr : O_Assoc_List; -- begin --- Start_Association (Constr, Ghdl_Signal_Direct_Driver); +-- Start_Association (Constr, Ghdl_Signal_Add_Direct_Driver); -- New_Association -- (Constr, New_Convert_Ov (New_Value (M2Lv (Sig)), Ghdl_Signal_Ptr)); -- New_Association @@ -25298,225 +25287,22 @@ package body Translation is Pinfo.Ortho_Type (Mode_Value)); end Translate_Value_Attribute; - -- Current path for name attributes. - Path_Str : String_Acc := null; - Path_Maxlen : Natural := 0; - Path_Len : Natural; - Path_Instance : Iir; - - procedure Deallocate is new Ada.Unchecked_Deallocation - (Name => String_Acc, Object => String); - - procedure Path_Reset is - begin - Path_Len := 0; - Path_Instance := Null_Iir; - if Path_Maxlen = 0 then - Path_Maxlen := 256; - Path_Str := new String (1 .. Path_Maxlen); - end if; - end Path_Reset; - - procedure Path_Add (Str : String) - is - N_Len : Natural; - N_Path : String_Acc; - begin - N_Len := Path_Maxlen; - loop - exit when Path_Len + Str'Length <= N_Len; - N_Len := N_Len * 2; - end loop; - if N_Len /= Path_Maxlen then - N_Path := new String (1 .. N_Len); - N_Path (1 .. Path_Len) := Path_Str (1 .. Path_Len); - Deallocate (Path_Str); - Path_Str := N_Path; - Path_Maxlen := N_Len; - end if; - Path_Str (Path_Len + 1 .. Path_Len + Str'Length) := Str; - Path_Len := Path_Len + Str'Length; - end Path_Add; - - procedure Path_Add_Type_Name (Atype : Iir) - is - use Name_Table; - Adecl : Iir; - begin - Adecl := Get_Type_Declarator (Atype); - Image (Get_Identifier (Adecl)); - Path_Add (Name_Buffer (1 .. Name_Length)); - end Path_Add_Type_Name; - - procedure Path_Add_Signature (Subprg : Iir) - is - Chain : Iir; - begin - Path_Add ("["); - Chain := Get_Interface_Declaration_Chain (Subprg); - while Chain /= Null_Iir loop - Path_Add_Type_Name (Get_Type (Chain)); - Chain := Get_Chain (Chain); - if Chain /= Null_Iir then - Path_Add (","); - end if; - end loop; - - case Get_Kind (Subprg) is - when Iir_Kind_Function_Declaration - | Iir_Kind_Implicit_Function_Declaration => - Path_Add (" return "); - Path_Add_Type_Name (Get_Return_Type (Subprg)); - when others => - null; - end case; - Path_Add ("]"); - end Path_Add_Signature; - - procedure Path_Add_Name (N : Iir) - is - use Name_Table; - begin - Eval_Simple_Name (Get_Identifier (N)); - if Name_Buffer (1) /= 'P' then - -- Skip anonymous processes. - Path_Add (Name_Buffer (1 .. Name_Length)); - end if; - end Path_Add_Name; - - procedure Path_Add_Element (El : Iir; Is_Instance : Boolean) - is - begin - -- LRM 14.1 - -- E'INSTANCE_NAME - -- There is one full pah instance element for each component - -- instantiation, block statement, generate statemenent, process - -- statement, or subprogram body in the design hierarchy between - -- the top design entity and the named entity denoted by the - -- prefix. - -- - -- E'PATH_NAME - -- There is one path instance element for each component - -- instantiation, block statement, generate statement, process - -- statement, or subprogram body in the design hierarchy between - -- the root design entity and the named entity denoted by the - -- prefix. - case Get_Kind (El) is - when Iir_Kind_Library_Declaration => - Path_Add (":"); - Path_Add_Name (El); - Path_Add (":"); - when Iir_Kind_Package_Declaration => - Path_Add_Element - (Get_Library (Get_Design_File (Get_Design_Unit (El))), - Is_Instance); - Path_Add_Name (El); - Path_Add (":"); - when Iir_Kind_Entity_Declaration => - Path_Instance := El; - when Iir_Kind_Architecture_Declaration => - Path_Instance := El; - when Iir_Kind_Design_Unit => - Path_Add_Element (Get_Library_Unit (El), Is_Instance); - when Iir_Kind_Sensitized_Process_Statement - | Iir_Kind_Process_Statement - | Iir_Kind_Block_Statement => - Path_Add_Element (Get_Parent (El), Is_Instance); - Path_Add_Name (El); - Path_Add (":"); - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration - | Iir_Kind_Implicit_Function_Declaration - | Iir_Kind_Implicit_Procedure_Declaration => - Path_Add_Element (Get_Parent (El), Is_Instance); - Path_Add_Name (El); - if Flags.Vhdl_Std >= Vhdl_02 then - -- Add signature. - Path_Add_Signature (El); - end if; - Path_Add (":"); - when Iir_Kind_Procedure_Body => - Path_Add_Element (Get_Subprogram_Specification (El), - Is_Instance); - when Iir_Kind_Generate_Statement => - declare - Scheme : Iir; - begin - Scheme := Get_Generation_Scheme (El); - if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then - Path_Instance := El; - else - Path_Add_Element (Get_Parent (El), Is_Instance); - Path_Add_Name (El); - Path_Add (":"); - end if; - end; - when Iir_Kinds_Sequential_Statement => - Path_Add_Element (Get_Parent (El), Is_Instance); - when others => - Error_Kind ("path_add_element", El); - end case; - end Path_Add_Element; - function Translate_Path_Instance_Name_Attribute (Attr : Iir) return O_Enode is - Prefix : Iir; + Name : constant Path_Instance_Name_Type := + Get_Path_Instance_Name_Suffix (Attr); Res : O_Dnode; Name_Cst : O_Dnode; Str_Cst : O_Cnode; Constr : O_Assoc_List; - Is_Instance : Boolean; + Is_Instance : constant Boolean := + Get_Kind (Attr) = Iir_Kind_Instance_Name_Attribute; begin - Prefix := Get_Prefix (Attr); - Is_Instance := Get_Kind (Attr) = Iir_Kind_Instance_Name_Attribute; - - Path_Reset; - - -- LRM 14.1 - -- E'PATH_NAME - -- The local item name in E'PATH_NAME equals E'SIMPLE_NAME, unless - -- E denotes a library, package, subprogram or label. In this - -- latter case, the package based path or instance based path, - -- as appropriate, will not contain a local item name. - -- - -- E'INSTANCE_NAME - -- The local item name in E'INSTANCE_NAME equals E'SIMPLE_NAME, - -- unless E denotes a library, package, subprogram, or label. In - -- this latter case, the package based path or full instance based - -- path, as appropriate, will not contain a local item name. - case Get_Kind (Prefix) is - when Iir_Kind_Constant_Declaration - | Iir_Kind_Constant_Interface_Declaration - | Iir_Kind_Iterator_Declaration - | Iir_Kind_Variable_Declaration - | Iir_Kind_Variable_Interface_Declaration - | Iir_Kind_Signal_Declaration - | Iir_Kind_Signal_Interface_Declaration - | Iir_Kind_File_Declaration - | Iir_Kind_File_Interface_Declaration - | Iir_Kind_Type_Declaration - | Iir_Kind_Subtype_Declaration => - Path_Add_Element (Get_Parent (Prefix), Is_Instance); - Path_Add_Name (Prefix); - when Iir_Kind_Library_Declaration - | Iir_Kind_Design_Unit - | Iir_Kind_Package_Declaration - | Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration - | Iir_Kind_Implicit_Function_Declaration - | Iir_Kind_Implicit_Procedure_Declaration - | Iir_Kinds_Concurrent_Statement - | Iir_Kinds_Sequential_Statement => - Path_Add_Element (Prefix, Is_Instance); - when others => - Error_Kind ("translate_path_instance_name_attribute", Prefix); - end case; Create_Temp_Stack2_Mark; Res := Create_Temp (Std_String_Node); - Str_Cst := Create_String_Len (Path_Str (1 .. Path_Len), - Create_Uniq_Identifier); + Str_Cst := Create_String_Len (Name.Suffix, Create_Uniq_Identifier); New_Const_Decl (Name_Cst, Create_Uniq_Identifier, O_Storage_Private, Ghdl_Str_Len_Type_Node); Start_Const_Value (Name_Cst); @@ -25528,10 +25314,10 @@ package body Translation is end if; New_Association (Constr, New_Address (New_Obj (Res), Std_String_Ptr_Node)); - if Path_Instance = Null_Iir then + if Name.Path_Instance = Null_Iir then Rtis.Associate_Null_Rti_Context (Constr); else - Rtis.Associate_Rti_Context (Constr, Path_Instance); + Rtis.Associate_Rti_Context (Constr, Name.Path_Instance); end if; New_Association (Constr, New_Address (New_Obj (Name_Cst), @@ -29106,9 +28892,6 @@ package body Translation is New_Record_Field (Rec, Ghdl_Signal_Last_Active_Field, Get_Identifier ("last_active"), Time_Otype); - New_Record_Field (Rec, Ghdl_Signal_Active_Chain_Field, - Get_Identifier ("active_chain"), - Ghdl_Signal_Ptr); New_Record_Field (Rec, Ghdl_Signal_Event_Field, Get_Identifier ("event"), Std_Boolean_Type_Node); @@ -29124,11 +28907,6 @@ package body Translation is New_Type_Decl (Get_Identifier ("__ghdl_signal_ptr_ptr"), Ghdl_Signal_Ptr_Ptr); - New_Var_Decl (Ghdl_Signal_Active_Chain, - Get_Identifier ("__ghdl_signal_active_chain"), - O_Storage_External, - Ghdl_Signal_Ptr); - -- procedure __ghdl_signal_merge_rti -- (sig : ghdl_signal_ptr; rti : ghdl_rti_access) Start_Procedure_Decl @@ -29370,16 +29148,24 @@ package body Translation is New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Add_Driver); - -- procedure __ghdl_signal_direct_driver (sig : __ghdl_signal_ptr; - -- Drv : Ghdl_Ptr_type); + -- procedure __ghdl_signal_add_direct_driver (sig : __ghdl_signal_ptr; + -- Drv : Ghdl_Ptr_type); Start_Procedure_Decl - (Interfaces, Get_Identifier ("__ghdl_signal_direct_driver"), + (Interfaces, Get_Identifier ("__ghdl_signal_add_direct_driver"), O_Storage_External); New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); New_Interface_Decl (Interfaces, Param, Get_Identifier ("drv"), Ghdl_Ptr_Type); - Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Direct_Driver); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Add_Direct_Driver); + + -- procedure __ghdl_signal_direct_assign (sig : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_direct_assign"), + O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Direct_Assign); declare procedure Create_Signal_Conversion (Name : String; Res : out O_Dnode) @@ -29925,47 +29711,6 @@ package body Translation is O_Storage_Public); end Gen_Setup_Info; - -- Return TRUE iff ENTITY can be at the top of a hierarchy, ie: - -- ENTITY has no generics or all generics have a default expression - -- ENTITY has no ports or all ports type are constrained. - procedure Check_Entity_Declaration_Top (Entity : Iir_Entity_Declaration) - is - Has_Error : Boolean := False; - - procedure Error (Msg : String; Loc : Iir) is - begin - if not Has_Error then - Error_Msg_Elab - (Disp_Node (Entity) & " cannot be at the top of a design"); - Has_Error := True; - end if; - Error_Msg_Elab (Msg, Loc); - end Error; - - El : Iir; - begin - -- Check generics. - El := Get_Generic_Chain (Entity); - while El /= Null_Iir loop - if Get_Default_Value (El) = Null_Iir then - Error ("(" & Disp_Node (El) & " has no default value)", El); - end if; - El := Get_Chain (El); - end loop; - - -- Check port. - El := Get_Port_Chain (Entity); - while El /= Null_Iir loop - if not Is_Fully_Constrained_Type (Get_Type (El)) - and then Get_Default_Value (El) = Null_Iir - then - Error ("(" & Disp_Node (El) - & " is unconstrained and has no default value)", El); - end if; - El := Get_Chain (El); - end loop; - end Check_Entity_Declaration_Top; - procedure Gen_Last_Arch (Entity : Iir_Entity_Declaration) is Entity_Info : Block_Info_Acc; |