diff options
Diffstat (limited to 'translate/translation.adb')
| -rw-r--r-- | translate/translation.adb | 1335 |
1 files changed, 1144 insertions, 191 deletions
diff --git a/translate/translation.adb b/translate/translation.adb index 7a6f387..b2294bb 100644 --- a/translate/translation.adb +++ b/translate/translation.adb @@ -38,7 +38,12 @@ with Sem; with Iir_Chains; use Iir_Chains; with Nodes; with GNAT.Table; +with Ieee.Std_Logic_1164; with Canon; +with Canon_PSL; +with PSL.Nodes; +with PSL.NFAs; +with PSL.NFAs.Utils; with Trans_Decls; use Trans_Decls; with Trans_Analyzes; @@ -48,6 +53,10 @@ package body Translation is Std_Boolean_Type_Node : O_Tnode; Std_Boolean_True_Node : O_Cnode; Std_Boolean_False_Node : O_Cnode; + -- Array of STD.BOOLEAN. + Std_Boolean_Array_Type : O_Tnode; + -- Std_ulogic indexed array of STD.Boolean. + Std_Ulogic_Boolean_Array_Type : O_Tnode; -- Ortho type node for string template pointer. Std_String_Ptr_Node : O_Tnode; Std_String_Node : O_Tnode; @@ -149,36 +158,29 @@ package body Translation is type Object_Kind_Type is (Mode_Value, Mode_Signal); -- Well known identifiers. - type Wk_Ident_Type is - ( - Wkie_This, Wkie_Size, Wkie_Res, Wkie_Dir_To, Wkie_Dir_Downto, - Wkie_Left, Wkie_Right, Wkie_Dir, Wkie_Length, Wkie_Kind, Wkie_Dim, - Wkie_I, Wkie_Instance, Wkie_Arch_Instance, Wkie_Name, Wkie_Sig, - Wkie_Obj, Wkie_Rti, Wkie_Parent, Wkie_Filename, Wkie_Line - ); - type Wk_Ident_Tree_Array is array (Wk_Ident_Type) of O_Ident; - Wk_Idents : Wk_Ident_Tree_Array; - Wki_This : O_Ident renames Wk_Idents (Wkie_This); - Wki_Size : O_Ident renames Wk_Idents (Wkie_Size); - Wki_Res : O_Ident renames Wk_Idents (Wkie_Res); - Wki_Dir_To : O_Ident renames Wk_Idents (Wkie_Dir_To); - Wki_Dir_Downto : O_Ident renames Wk_Idents (Wkie_Dir_Downto); - Wki_Left : O_Ident renames Wk_Idents (Wkie_Left); - Wki_Right : O_Ident renames Wk_Idents (Wkie_Right); - Wki_Dir : O_Ident renames Wk_Idents (Wkie_Dir); - Wki_Length : O_Ident renames Wk_Idents (Wkie_Length); - Wki_Kind : O_Ident renames Wk_Idents (Wkie_Kind); - Wki_Dim : O_Ident renames Wk_Idents (Wkie_Dim); - Wki_I : O_Ident renames Wk_Idents (Wkie_I); - Wki_Instance : O_Ident renames Wk_Idents (Wkie_Instance); - Wki_Arch_Instance : O_Ident renames Wk_Idents (Wkie_Arch_Instance); - Wki_Name : O_Ident renames Wk_Idents (Wkie_Name); - Wki_Sig : O_Ident renames Wk_Idents (Wkie_Sig); - Wki_Obj : O_Ident renames Wk_Idents (Wkie_Obj); - Wki_Rti : O_Ident renames Wk_Idents (Wkie_Rti); - Wki_Parent : O_Ident renames Wk_Idents (Wkie_Parent); - Wki_Filename : O_Ident renames Wk_Idents (Wkie_Filename); - Wki_Line : O_Ident renames Wk_Idents (Wkie_Line); + Wki_This : O_Ident; + Wki_Size : O_Ident; + Wki_Res : O_Ident; + Wki_Dir_To : O_Ident; + Wki_Dir_Downto : O_Ident; + Wki_Left : O_Ident; + Wki_Right : O_Ident; + Wki_Dir : O_Ident; + Wki_Length : O_Ident; + Wki_I : O_Ident; + Wki_Instance : O_Ident; + Wki_Arch_Instance : O_Ident; + Wki_Name : O_Ident; + Wki_Sig : O_Ident; + Wki_Obj : O_Ident; + Wki_Rti : O_Ident; + Wki_Parent : O_Ident; + Wki_Filename : O_Ident; + Wki_Line : O_Ident; + Wki_Lo : O_Ident; + Wki_Hi : O_Ident; + Wki_Mid : O_Ident; + Wki_Cmp : O_Ident; -- ALLOCATION_KIND defines the type of memory storage. -- ALLOC_STACK means the object is allocated on the local stack and @@ -603,6 +605,8 @@ package body Translation is Dir : Iir_Direction; Val : Unsigned_64; Itype : Iir); + + procedure Translate_Report (Stmt : Iir; Subprg : O_Dnode; Level : Iir); end Chap8; package Chap9 is @@ -670,6 +674,7 @@ package body Translation is Ghdl_Rtik_Attribute_Transaction : O_Cnode; Ghdl_Rtik_Attribute_Quiet : O_Cnode; Ghdl_Rtik_Attribute_Stable : O_Cnode; + Ghdl_Rtik_Psl_Assert : O_Cnode; Ghdl_Rtik_Error : O_Cnode; -- RTI types. @@ -757,6 +762,7 @@ package body Translation is Kind_Interface, Kind_Disconnect, Kind_Process, + Kind_Psl_Assert, Kind_Loop, Kind_Block, Kind_Component, @@ -764,6 +770,7 @@ package body Translation is Kind_Package, Kind_Config, Kind_Assoc, + Kind_Str_Choice, Kind_Design_File, Kind_Library ); @@ -1166,6 +1173,29 @@ package body Translation is -- RTI for the process. Process_Rti_Const : O_Dnode := O_Dnode_Null; + when Kind_Psl_Assert => + -- Type of assert declarations record. + Psl_Decls_Type : O_Tnode; + + -- Field in the parent block for the declarations in the assert. + Psl_Parent_Field : O_Fnode; + + -- Procedure for the state machine. + Psl_Proc_Subprg : O_Dnode; + -- Procedure for finalization. Handles EOS. + Psl_Proc_Final_Subprg : O_Dnode; + + -- Length of the state vector. + Psl_Vect_Len : Natural; + + -- Type of the state vector. + Psl_Vect_Type : O_Tnode; + + -- State vector variable. + Psl_Vect_Var : Var_Acc; + + -- RTI for the process. + Psl_Rti_Const : O_Dnode := O_Dnode_Null; when Kind_Loop => -- Labels for the loop. -- Used for exit/next from while-loop, and to exit from for-loop. @@ -1245,6 +1275,15 @@ package body Translation is -- Association informations. Assoc_In : Assoc_Conv_Info; Assoc_Out : Assoc_Conv_Info; + when Kind_Str_Choice => + -- List of choices, used to sort them. + Choice_Chain : Ortho_Info_Acc; + -- Association index. + Choice_Assoc : Natural; + -- Corresponding choice simple expression. + Choice_Expr : Iir; + -- Corresponding choice. + Choice_Parent : Iir; when Kind_Design_File => Design_Filename : O_Dnode; when Kind_Library => @@ -1261,6 +1300,7 @@ package body Translation is subtype Object_Info_Acc is Ortho_Info_Acc (Kind_Object); subtype Alias_Info_Acc is Ortho_Info_Acc (Kind_Alias); subtype Proc_Info_Acc is Ortho_Info_Acc (Kind_Process); + subtype Psl_Info_Acc is Ortho_Info_Acc (Kind_Psl_Assert); subtype Loop_Info_Acc is Ortho_Info_Acc (Kind_Loop); subtype Block_Info_Acc is Ortho_Info_Acc (Kind_Block); subtype Comp_Info_Acc is Ortho_Info_Acc (Kind_Component); @@ -2020,6 +2060,8 @@ package body Translation is Prg_Err_Missing_Return : constant Natural := 1; Prg_Err_Block_Configured : constant Natural := 2; Prg_Err_Dummy_Config : constant Natural := 3; + Prg_Err_No_Choice : constant Natural := 4; + Prg_Err_Bad_Choice : constant Natural := 5; procedure Gen_Program_Error (Loc : Iir; Code : Natural); -- Generate code to emit a failure if COND is TRUE, indicating an @@ -2276,6 +2318,8 @@ package body Translation is procedure Gen_Exit_When (Label : O_Snode; Cond : O_Enode); -- Create a uniq identifier. + subtype Uniq_Identifier_String is String (1 .. 11); + function Create_Uniq_Identifier return Uniq_Identifier_String; function Create_Uniq_Identifier return O_Ident; -- Create a region for temporary variables. @@ -2317,6 +2361,9 @@ package body Translation is -- Used only to free memory. procedure Free_Old_Temp; + -- Return a ghdl_index_type literal for NUM. + function New_Index_Lit (Num : Unsigned_64) return O_Cnode; + -- Create a constant (of name ID) for string STR. -- Append a NUL terminator (to make interfaces with C easier). function Create_String (Str : String; Id : O_Ident) return O_Dnode; @@ -2968,9 +3015,9 @@ package body Translation is Ptr : String_Fat_Acc; begin Ptr := Get_String_Fat_Acc (Expr); - Name_Length := Get_String_Length (Expr); + Name_Length := Natural (Get_String_Length (Expr)); for I in 1 .. Name_Length loop - Name_Buffer (I) := Ptr (I); + Name_Buffer (I) := Ptr (Nat32 (I)); end loop; end; when Iir_Kind_Simple_Aggregate => @@ -3163,9 +3210,9 @@ package body Translation is Uniq_Id : Natural := 0; - function Create_Uniq_Identifier return O_Ident + function Create_Uniq_Identifier return Uniq_Identifier_String is - Str : String (1 .. 12); + Str : Uniq_Identifier_String; Val : Natural; begin Str (1 .. 3) := "_UI"; @@ -3175,8 +3222,12 @@ package body Translation is Str (I) := N2hex (Val mod 16); Val := Val / 16; end loop; - --Str (12) := Nul; - return Get_Identifier (Str (1 .. 11)); + return Str; + end Create_Uniq_Identifier; + + function Create_Uniq_Identifier return O_Ident is + begin + return Get_Identifier (Create_Uniq_Identifier); end Create_Uniq_Identifier; -- Create a temporary variable. @@ -3407,6 +3458,12 @@ package body Translation is return Create_Temp_Init (Temp_Type, New_Address (Name, Temp_Type)); end Create_Temp_Ptr; + -- Return a ghdl_index_type literal for NUM. + function New_Index_Lit (Num : Unsigned_64) return O_Cnode is + begin + return New_Unsigned_Literal (Ghdl_Index_Type, Num); + end New_Index_Lit; + -- Convert NAME into a STRING_CST. -- Append a NUL terminator (to make interfaces with C easier). function Create_String_Type (Str : String) return O_Tnode is @@ -10853,6 +10910,7 @@ package body Translation is then case Get_Implicit_Definition (El) is when Iir_Predefined_Array_Equality + | Iir_Predefined_Array_Greater | Iir_Predefined_Record_Equality => -- Used implicitly in case statement or other -- predefined equality. @@ -13365,7 +13423,7 @@ package body Translation is Literal_List : Iir_List; Lit : Iir; - Len : Natural; + Len : Nat32; Ptr : String_Fat_Acc; begin Literal_List := @@ -13387,7 +13445,7 @@ package body Translation is L_0 : O_Cnode; L_1 : O_Cnode; Ptr : String_Fat_Acc; - Len : Natural; + Len : Nat32; V : O_Cnode; begin L_0 := Get_Ortho_Expr (Get_Bit_String_0 (Lit)); @@ -13506,14 +13564,16 @@ package body Translation is Lit_Type : Iir; Element_Type : Iir; + Arr_Type : O_Tnode; List : O_Array_Aggr_List; Res : O_Cnode; begin Lit_Type := Get_Type (Str); Chap3.Translate_Anonymous_Type_Definition (Lit_Type, True); + Arr_Type := Get_Ortho_Type (Lit_Type, Mode_Value); - Start_Array_Aggr (List, Get_Ortho_Type (Lit_Type, Mode_Value)); + Start_Array_Aggr (List, Arr_Type); Element_Type := Get_Element_Subtype (Lit_Type); @@ -13526,8 +13586,8 @@ package body Translation is -- Some strings literal have an unconstrained array type, -- eg: 'image of constant. Its type is not constrained -- because it is not so in VHDL! - function Translate_Static_Unconstrained_String_Literal (Str : Iir) - return O_Cnode + function Translate_Non_Static_String_Literal (Str : Iir) + return O_Enode is use Name_Table; @@ -13545,9 +13605,10 @@ package body Translation is Len : Int32; Val : Var_Acc; Bound : Var_Acc; + R : O_Enode; begin Lit_Type := Get_Type (Str); - Type_Info := Get_Info (Get_Base_Type (Lit_Type)); + Type_Info := Get_Info (Lit_Type); -- Create the string value. Len := Get_String_Length (Str); @@ -13557,51 +13618,76 @@ package body Translation is Start_Array_Aggr (Val_Aggr, Str_Type); Element_Type := Get_Element_Subtype (Lit_Type); - Translate_Static_String_Literal_Inner (Val_Aggr, Str, Element_Type); + case Get_Kind (Str) is + when Iir_Kind_String_Literal => + Translate_Static_String_Literal_Inner + (Val_Aggr, Str, Element_Type); + when Iir_Kind_Bit_String_Literal => + Translate_Static_Bit_String_Literal_Inner + (Val_Aggr, Str, Element_Type); + when others => + raise Internal_Error; + end case; Finish_Array_Aggr (Val_Aggr, Res); Val := Create_Global_Const (Create_Uniq_Identifier, Str_Type, O_Storage_Private, Res); - -- Create the string bound. - Index_Type := Get_First_Element (Get_Index_Subtype_List (Lit_Type)); - Index_Type_Info := Get_Info (Index_Type); - Start_Record_Aggr (Bound_Aggr, Type_Info.T.Bounds_Type); - Start_Record_Aggr (Index_Aggr, Index_Type_Info.T.Range_Type); - New_Record_Aggr_El - (Index_Aggr, - New_Signed_Literal (Index_Type_Info.Ortho_Type (Mode_Value), 0)); - New_Record_Aggr_El - (Index_Aggr, - New_Signed_Literal (Index_Type_Info.Ortho_Type (Mode_Value), + if Type_Info.Type_Mode = Type_Mode_Fat_Array then + -- Create the string bound. + Index_Type := + Get_First_Element (Get_Index_Subtype_List (Lit_Type)); + Index_Type_Info := Get_Info (Index_Type); + Start_Record_Aggr (Bound_Aggr, Type_Info.T.Bounds_Type); + Start_Record_Aggr (Index_Aggr, Index_Type_Info.T.Range_Type); + New_Record_Aggr_El + (Index_Aggr, + New_Signed_Literal + (Index_Type_Info.Ortho_Type (Mode_Value), 0)); + New_Record_Aggr_El + (Index_Aggr, + New_Signed_Literal (Index_Type_Info.Ortho_Type (Mode_Value), Integer_64 (Len - 1))); - New_Record_Aggr_El - (Index_Aggr, Ghdl_Dir_To_Node); - New_Record_Aggr_El - (Index_Aggr, - New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Len))); - Finish_Record_Aggr (Index_Aggr, Res); - New_Record_Aggr_El (Bound_Aggr, Res); - Finish_Record_Aggr (Bound_Aggr, Res); - Bound := Create_Global_Const - (Create_Uniq_Identifier, Type_Info.T.Bounds_Type, - O_Storage_Private, Res); - - -- The descriptor. - Start_Record_Aggr (Res_Aggr, Type_Info.Ortho_Type (Mode_Value)); - New_Record_Aggr_El - (Res_Aggr, - New_Global_Address (Get_Var_Label (Val), - Type_Info.T.Base_Ptr_Type (Mode_Value))); - New_Record_Aggr_El - (Res_Aggr, - New_Global_Address (Get_Var_Label (Bound), - Type_Info.T.Bounds_Ptr_Type)); - Finish_Record_Aggr (Res_Aggr, Res); + New_Record_Aggr_El + (Index_Aggr, Ghdl_Dir_To_Node); + New_Record_Aggr_El + (Index_Aggr, + New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Len))); + Finish_Record_Aggr (Index_Aggr, Res); + New_Record_Aggr_El (Bound_Aggr, Res); + Finish_Record_Aggr (Bound_Aggr, Res); + Bound := Create_Global_Const + (Create_Uniq_Identifier, Type_Info.T.Bounds_Type, + O_Storage_Private, Res); + + -- The descriptor. + Start_Record_Aggr (Res_Aggr, Type_Info.Ortho_Type (Mode_Value)); + New_Record_Aggr_El + (Res_Aggr, + New_Global_Address (Get_Var_Label (Val), + Type_Info.T.Base_Ptr_Type (Mode_Value))); + New_Record_Aggr_El + (Res_Aggr, + New_Global_Address (Get_Var_Label (Bound), + Type_Info.T.Bounds_Ptr_Type)); + Finish_Record_Aggr (Res_Aggr, Res); + Free_Var (Val); + Free_Var (Bound); + + Val := Create_Global_Const + (Create_Uniq_Identifier, Type_Info.Ortho_Type (Mode_Value), + O_Storage_Private, Res); + elsif Type_Info.Type_Mode = Type_Mode_Ptr_Array then + null; + else + raise Internal_Error; + end if; + + R := New_Address (Get_Var (Val), + Type_Info.Ortho_Ptr_Type (Mode_Value)); Free_Var (Val); - Free_Var (Bound); - return Res; - end Translate_Static_Unconstrained_String_Literal; + return R; + end Translate_Non_Static_String_Literal; -- Only for Strings of STD.Character. function Translate_Static_String (Str_Type : Iir; Str_Ident : Name_Id) @@ -13655,33 +13741,36 @@ package body Translation is Res : O_Cnode; R : O_Enode; begin - case Get_Kind (Str) is - when Iir_Kind_String_Literal => - if Get_Kind (Get_Type (Str)) - = Iir_Kind_Array_Subtype_Definition - then - Res := Translate_Static_String_Literal (Str); - else - Res := Translate_Static_Unconstrained_String_Literal (Str); - end if; - when Iir_Kind_Bit_String_Literal => - Res := Translate_Static_Bit_String_Literal (Str); - when Iir_Kind_Simple_Aggregate => - Res := Translate_Static_Simple_Aggregate (Str); - when Iir_Kind_Simple_Name_Attribute => - Res := Translate_Static_String - (Get_Type (Str), Get_Simple_Name_Identifier (Str)); - when others => - raise Internal_Error; - end case; Str_Type := Get_Type (Str); - Info := Get_Info (Str_Type); - Var := Create_Global_Const - (Create_Uniq_Identifier, Info.Ortho_Type (Mode_Value), - O_Storage_Private, Res); - R := New_Address (Get_Var (Var), Info.Ortho_Ptr_Type (Mode_Value)); - Free_Var (Var); - return R; + if Get_Constraint_State (Str_Type) = Fully_Constrained + and then Get_Type_Staticness + (Get_First_Element (Get_Index_Subtype_List (Str_Type))) + = Locally + then + case Get_Kind (Str) is + when Iir_Kind_String_Literal => + Res := Translate_Static_String_Literal (Str); + when Iir_Kind_Bit_String_Literal => + Res := Translate_Static_Bit_String_Literal (Str); + when Iir_Kind_Simple_Aggregate => + Res := Translate_Static_Simple_Aggregate (Str); + when Iir_Kind_Simple_Name_Attribute => + Res := Translate_Static_String + (Get_Type (Str), Get_Simple_Name_Identifier (Str)); + when others => + raise Internal_Error; + end case; + Str_Type := Get_Type (Str); + Info := Get_Info (Str_Type); + Var := Create_Global_Const + (Create_Uniq_Identifier, Info.Ortho_Type (Mode_Value), + O_Storage_Private, Res); + R := New_Address (Get_Var (Var), Info.Ortho_Ptr_Type (Mode_Value)); + Free_Var (Var); + return R; + else + return Translate_Non_Static_String_Literal (Str); + end if; end Translate_String_Literal; function Translate_Static_Implicit_Conv @@ -15067,7 +15156,7 @@ package body Translation is Lit : Iir; Pos : O_Enode; Ptr : String_Fat_Acc; - Len : Natural; + Len : Nat32; begin Ptr := Get_String_Fat_Acc (Aggr); Len := Get_String_Length (Aggr); @@ -15083,7 +15172,7 @@ package body Translation is (ON_Add_Ov, New_Obj_Value (Var_Index), New_Lit (New_Unsigned_Literal - (Ghdl_Index_Type, Natural'Pos (I - 1)))); + (Ghdl_Index_Type, Nat32'Pos (I - 1)))); end if; New_Assign_Stmt (M2Lv (Chap3.Index_Base (Base_Ptr, Aggr_Type, Pos)), @@ -15095,7 +15184,7 @@ package body Translation is (ON_Add_Ov, New_Obj_Value (Var_Index), New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, - Natural'Pos (Len))))); + Nat32'Pos (Len))))); end; return; when Iir_Kind_Bit_String_Literal => @@ -15504,7 +15593,7 @@ package body Translation is -- FIXME: creating aggregate subtype is expensive and rarely used. -- (one of the current use - only ? - is check_array_match). - Chap3.Translate_Type_Definition (Aggr_Type, False); + Chap3.Translate_Anonymous_Type_Definition (Aggr_Type, False); end Translate_Array_Aggregate; procedure Translate_Aggregate @@ -18879,9 +18968,10 @@ package body Translation is Translate_Report (Stmt, Ghdl_Report, Severity_Level_Note); end Translate_Report_Statement; + -- Helper to compare a string choice with the selector. function Translate_Simple_String_Choice (Expr : O_Dnode; - Val : Iir; + Val : O_Enode; Val_Node : O_Dnode; Tinfo : Type_Info_Acc; Func : Iir) @@ -18893,7 +18983,7 @@ package body Translation is New_Assign_Stmt (New_Selected_Element (New_Obj (Val_Node), Tinfo.T.Base_Field (Mode_Value)), - Chap7.Translate_Expression (Val, Get_Type (Val))); + Val); Func_Info := Get_Info (Func); Start_Association (Assoc, Func_Info.Ortho_Func); Chap2.Add_Subprg_Instance_Assoc (Assoc, Func_Info.Subprg_Instance); @@ -18904,107 +18994,462 @@ package body Translation is return New_Function_Call (Assoc); end Translate_Simple_String_Choice; - procedure Translate_String_Choice - (Expr : O_Dnode; - Val_Node : O_Dnode; + -- Helper to evaluate the selector and preparing a choice variable. + procedure Translate_String_Case_Statement_Common + (Stmt : Iir_Case_Statement; + Expr_Type : out Iir; + Tinfo : out Type_Info_Acc; + Expr_Node : out O_Dnode; + C_Node : out O_Dnode) + is + Expr : Iir; + Base_Type : Iir; + begin + -- Translate into if/elsif statements. + -- FIXME: if the number of literals ** length of the array < 256, + -- use a case statement. + Expr := Get_Expression (Stmt); + Expr_Type := Get_Type (Expr); + Base_Type := Get_Base_Type (Expr_Type); + Tinfo := Get_Info (Base_Type); + + -- Translate selector. + Expr_Node := Create_Temp_Init + (Tinfo.Ortho_Ptr_Type (Mode_Value), + Chap7.Translate_Expression (Expr, Base_Type)); + + -- Copy the bounds for the choices. + C_Node := Create_Temp (Tinfo.Ortho_Type (Mode_Value)); + New_Assign_Stmt + (New_Selected_Element (New_Obj (C_Node), + Tinfo.T.Bounds_Field (Mode_Value)), + New_Value_Selected_Acc_Value + (New_Obj (Expr_Node), Tinfo.T.Bounds_Field (Mode_Value))); + end Translate_String_Case_Statement_Common; + + -- Translate a string case statement using a dichotomy. + procedure Translate_String_Case_Statement_Dichotomy + (Stmt : Iir_Case_Statement) + is + -- Selector. + Expr_Type : Iir; Tinfo : Type_Info_Acc; + Expr_Node : O_Dnode; + C_Node : O_Dnode; + + Choices_Chain : Iir; + Choice : Iir; + Has_Others : Boolean; Func : Iir; - Cond_Var : O_Dnode; - Choice : Iir) - is - Cond : O_Enode; - If_Blk : O_If_Block; - Stmt_Chain : Iir; - First : Boolean; - Ch : Iir; + + -- Number of non-others choices. + Nbr_Choices : Natural; + -- Number of associations. + Nbr_Assocs : Natural; + + Info : Ortho_Info_Acc; + First, Last : Ortho_Info_Acc; + Sel_Length : Iir_Int64; + + -- Dichotomy table (table of choices). + String_Type : O_Tnode; + Table_Base_Type : O_Tnode; + Table_Type : O_Tnode; + Table : O_Dnode; + List : O_Array_Aggr_List; + Table_Cst : O_Cnode; + + -- Association table. + -- Indexed by the choice, returns an index to the associated + -- statement list. + -- Could be replaced by jump table. + Assoc_Table_Base_Type : O_Tnode; + Assoc_Table_Type : O_Tnode; + Assoc_Table : O_Dnode; begin - if Choice = Null_Iir then - return; - end if; + Choices_Chain := Get_Case_Statement_Alternative_Chain (Stmt); - First := True; - Stmt_Chain := Get_Associated (Choice); - Ch := Choice; - loop - case Get_Kind (Ch) is - when Iir_Kind_Choice_By_Expression => - Cond := Translate_Simple_String_Choice - (Expr, Get_Expression (Ch), Val_Node, Tinfo, Func); + -- Count number of choices and number of associations. + Nbr_Choices := 0; + Nbr_Assocs := 0; + Choice := Choices_Chain; + First := null; + Last := null; + Has_Others := False; + while Choice /= Null_Iir loop + case Get_Kind (Choice) is when Iir_Kind_Choice_By_Others => - Translate_Statements_Chain (Stmt_Chain); - return; + Has_Others := True; + exit; + when Iir_Kind_Choice_By_Expression => + null; when others => - Error_Kind ("translate_string_choice", Ch); + raise Internal_Error; end case; - if not First then - New_Assign_Stmt - (New_Obj (Cond_Var), - New_Dyadic_Op (ON_Or, New_Obj_Value (Cond_Var), Cond)); + if not Get_Same_Alternative_Flag (Choice) then + Nbr_Assocs := Nbr_Assocs + 1; end if; - Ch := Get_Chain (Ch); - exit when Ch = Null_Iir; - exit when not Get_Same_Alternative_Flag (Ch); - exit when Get_Associated (Ch) /= Null_Iir; - if First then - New_Assign_Stmt (New_Obj (Cond_Var), Cond); - First := False; + Info := Add_Info (Choice, Kind_Str_Choice); + if First = null then + First := Info; + else + Last.Choice_Chain := Info; end if; + Last := Info; + Info.Choice_Chain := null; + Info.Choice_Assoc := Nbr_Assocs - 1; + Info.Choice_Parent := Choice; + Info.Choice_Expr := Get_Expression (Choice); + + Nbr_Choices := Nbr_Choices + 1; + Choice := Get_Chain (Choice); end loop; - if not First then - Cond := New_Obj_Value (Cond_Var); - end if; - Start_If_Stmt (If_Blk, Cond); - Translate_Statements_Chain (Stmt_Chain); - New_Else_Stmt (If_Blk); - Translate_String_Choice - (Expr, Val_Node, Tinfo, Func, Cond_Var, Ch); - Finish_If_Stmt (If_Blk); - end Translate_String_Choice; + + -- Sort choices. + declare + procedure Merge_Sort (Head : Ortho_Info_Acc; + Nbr : Natural; + Res : out Ortho_Info_Acc; + Next : out Ortho_Info_Acc) + is + L, R, L_End, R_End : Ortho_Info_Acc; + E, Last : Ortho_Info_Acc; + Half : constant Natural := Nbr / 2; + begin + -- Sorting less than 2 elements is easy! + if Nbr < 2 then + Res := Head; + if Nbr = 0 then + Next := Head; + else + Next := Head.Choice_Chain; + end if; + return; + end if; + + Merge_Sort (Head, Half, L, L_End); + Merge_Sort (L_End, Nbr - Half, R, R_End); + Next := R_End; + + -- Merge + Last := null; + loop + if L /= L_End + and then + (R = R_End + or else + Compare_String_Literals (L.Choice_Expr, R.Choice_Expr) + = Compare_Lt) + then + E := L; + L := L.Choice_Chain; + elsif R /= R_End then + E := R; + R := R.Choice_Chain; + else + exit; + end if; + if Last = null then + Res := E; + else + Last.Choice_Chain := E; + end if; + Last := E; + end loop; + Last.Choice_Chain := R_End; + end Merge_Sort; + Next : Ortho_Info_Acc; + begin + Merge_Sort (First, Nbr_Choices, First, Next); + if Next /= null then + raise Internal_Error; + end if; + end; + + Translate_String_Case_Statement_Common + (Stmt, Expr_Type, Tinfo, Expr_Node, C_Node); + + -- Generate choices table. + Sel_Length := Eval_Discrete_Type_Length + (Get_String_Type_Bound_Type (Expr_Type)); + String_Type := New_Constrained_Array_Type + (Tinfo.T.Base_Type (Mode_Value), + New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Sel_Length))); + Table_Base_Type := New_Array_Type (String_Type, Ghdl_Index_Type); + New_Type_Decl (Create_Uniq_Identifier, Table_Base_Type); + Table_Type := New_Constrained_Array_Type + (Table_Base_Type, + New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Choices))); + New_Type_Decl (Create_Uniq_Identifier, Table_Type); + New_Const_Decl (Table, Create_Uniq_Identifier, O_Storage_Private, + Table_Type); + Start_Const_Value (Table); + Start_Array_Aggr (List, Table_Type); + Info := First; + while Info /= null loop + New_Array_Aggr_El (List, Chap7.Translate_Static_Expression + (Info.Choice_Expr, Expr_Type)); + Info := Info.Choice_Chain; + end loop; + Finish_Array_Aggr (List, Table_Cst); + Finish_Const_Value (Table, Table_Cst); + + -- Generate assoc table. + Assoc_Table_Base_Type := + New_Array_Type (Ghdl_Index_Type, Ghdl_Index_Type); + New_Type_Decl (Create_Uniq_Identifier, Assoc_Table_Base_Type); + Assoc_Table_Type := New_Constrained_Array_Type + (Assoc_Table_Base_Type, + New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Choices))); + New_Type_Decl (Create_Uniq_Identifier, Assoc_Table_Type); + New_Const_Decl (Assoc_Table, Create_Uniq_Identifier, + O_Storage_Private, Assoc_Table_Type); + Start_Const_Value (Assoc_Table); + Start_Array_Aggr (List, Assoc_Table_Type); + Info := First; + while Info /= null loop + New_Array_Aggr_El + (List, New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Info.Choice_Assoc))); + Info := Info.Choice_Chain; + end loop; + Finish_Array_Aggr (List, Table_Cst); + Finish_Const_Value (Assoc_Table, Table_Cst); + + -- Generate dichotomy code. + declare + Var_Lo, Var_Hi, Var_Mid : O_Dnode; + Var_Cmp : O_Dnode; + Var_Idx : O_Dnode; + Label : O_Snode; + Others_Lit : O_Cnode; + If_Blk1, If_Blk2 : O_If_Block; + Case_Blk : O_Case_Block; + begin + Var_Idx := Create_Temp (Ghdl_Index_Type); + + Start_Declare_Stmt; + + New_Var_Decl (Var_Lo, Wki_Lo, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_Hi, Wki_Hi, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_Mid, Wki_Mid, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_Cmp, Wki_Cmp, + O_Storage_Local, Ghdl_Compare_Type); + + New_Assign_Stmt (New_Obj (Var_Lo), New_Lit (Ghdl_Index_0)); + New_Assign_Stmt + (New_Obj (Var_Hi), + New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Nbr_Choices)))); + + Func := Chap7.Find_Predefined_Function + (Get_Base_Type (Expr_Type), Iir_Predefined_Array_Greater); + + if Has_Others then + Others_Lit := New_Unsigned_Literal + (Ghdl_Index_Type, Unsigned_64 (Nbr_Assocs)); + end if; + + Start_Loop_Stmt (Label); + New_Assign_Stmt + (New_Obj (Var_Mid), + New_Dyadic_Op (ON_Div_Ov, + New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (Var_Lo), + New_Obj_Value (Var_Hi)), + New_Lit (New_Unsigned_Literal + (Ghdl_Index_Type, 2)))); + New_Assign_Stmt + (New_Obj (Var_Cmp), + Translate_Simple_String_Choice + (Expr_Node, + New_Address (New_Indexed_Element (New_Obj (Table), + New_Obj_Value (Var_Mid)), + Tinfo.T.Base_Ptr_Type (Mode_Value)), + C_Node, Tinfo, Func)); + Start_If_Stmt + (If_Blk1, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_Cmp), + New_Lit (Ghdl_Compare_Eq), + Ghdl_Bool_Type)); + New_Assign_Stmt + (New_Obj (Var_Idx), + New_Value (New_Indexed_Element (New_Obj (Assoc_Table), + New_Obj_Value (Var_Mid)))); + New_Exit_Stmt (Label); + Finish_If_Stmt (If_Blk1); + + Start_If_Stmt + (If_Blk1, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_Cmp), + New_Lit (Ghdl_Compare_Lt), + Ghdl_Bool_Type)); + Start_If_Stmt + (If_Blk2, + New_Compare_Op (ON_Le, + New_Obj_Value (Var_Mid), + New_Obj_Value (Var_Lo), + Ghdl_Bool_Type)); + if not Has_Others then + Chap6.Gen_Program_Error (Stmt, Chap6.Prg_Err_Bad_Choice); + else + New_Assign_Stmt (New_Obj (Var_Idx), New_Lit (Others_Lit)); + New_Exit_Stmt (Label); + end if; + New_Else_Stmt (If_Blk2); + New_Assign_Stmt (New_Obj (Var_Hi), + New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (Var_Mid), + New_Lit (Ghdl_Index_1))); + Finish_If_Stmt (If_Blk2); + + New_Else_Stmt (If_Blk1); + + Start_If_Stmt + (If_Blk2, + New_Compare_Op (ON_Ge, + New_Obj_Value (Var_Mid), + New_Obj_Value (Var_Hi), + Ghdl_Bool_Type)); + if not Has_Others then + Chap6.Gen_Program_Error (Stmt, Chap6.Prg_Err_No_Choice); + else + New_Assign_Stmt (New_Obj (Var_Idx), New_Lit (Others_Lit)); + New_Exit_Stmt (Label); + end if; + New_Else_Stmt (If_Blk2); + New_Assign_Stmt (New_Obj (Var_Lo), + New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (Var_Mid), + New_Lit (Ghdl_Index_1))); + Finish_If_Stmt (If_Blk2); + + Finish_If_Stmt (If_Blk1); + + Finish_Loop_Stmt (Label); + + Finish_Declare_Stmt; + + Start_Case_Stmt (Case_Blk, New_Obj_Value (Var_Idx)); + + Choice := Choices_Chain; + while Choice /= Null_Iir loop + case Get_Kind (Choice) is + when Iir_Kind_Choice_By_Others => + Start_Choice (Case_Blk); + New_Expr_Choice (Case_Blk, Others_Lit); + Finish_Choice (Case_Blk); + Translate_Statements_Chain (Get_Associated (Choice)); + when Iir_Kind_Choice_By_Expression => + if not Get_Same_Alternative_Flag (Choice) then + Start_Choice (Case_Blk); + New_Expr_Choice + (Case_Blk, + New_Unsigned_Literal + (Ghdl_Index_Type, + Unsigned_64 (Get_Info (Choice).Choice_Assoc))); + Finish_Choice (Case_Blk); + Translate_Statements_Chain (Get_Associated (Choice)); + end if; + Free_Info (Choice); + when others => + raise Internal_Error; + end case; + Choice := Get_Chain (Choice); + end loop; + + Start_Choice (Case_Blk); + New_Default_Choice (Case_Blk); + Finish_Choice (Case_Blk); + Chap6.Gen_Program_Error (Stmt, Chap6.Prg_Err_No_Choice); + + Finish_Case_Stmt (Case_Blk); + end; + end Translate_String_Case_Statement_Dichotomy; -- Case statement whose expression is an unidim array. - procedure Translate_String_Case_Statement (Stmt : Iir_Case_Statement) + -- Translate into if/elsif statements (linear search). + procedure Translate_String_Case_Statement_Linear + (Stmt : Iir_Case_Statement) is - Expr : Iir; Expr_Type : Iir; - Base_Type : Iir; -- Node containing the address of the selector. Expr_Node : O_Dnode; -- Node containing the current choice. - C_Node : O_Dnode; + Val_Node : O_Dnode; Tinfo : Type_Info_Acc; - Choices_Chain : Iir; - Func : Iir; Cond_Var : O_Dnode; - begin - -- Translate into if/elsif statements. - -- FIXME: if the number of literals ** length of the array < 256, - -- use a case statement. - Expr := Get_Expression (Stmt); - Expr_Type := Get_Type (Expr); - Base_Type := Get_Base_Type (Expr_Type); - Tinfo := Get_Info (Base_Type); - Expr_Node := Create_Temp_Init - (Tinfo.Ortho_Ptr_Type (Mode_Value), - Chap7.Translate_Expression (Expr, Base_Type)); - C_Node := Create_Temp (Tinfo.Ortho_Type (Mode_Value)); - New_Assign_Stmt - (New_Selected_Element (New_Obj (C_Node), - Tinfo.T.Bounds_Field (Mode_Value)), - New_Value_Selected_Acc_Value - (New_Obj (Expr_Node), Tinfo.T.Bounds_Field (Mode_Value))); + Func : Iir; - Cond_Var := Create_Temp (Std_Boolean_Type_Node); + procedure Translate_String_Choice (Choice : Iir) + is + Cond : O_Enode; + If_Blk : O_If_Block; + Stmt_Chain : Iir; + First : Boolean; + Ch : Iir; + Ch_Expr : Iir; + begin + if Choice = Null_Iir then + return; + end if; + + First := True; + Stmt_Chain := Get_Associated (Choice); + Ch := Choice; + loop + case Get_Kind (Ch) is + when Iir_Kind_Choice_By_Expression => + Ch_Expr := Get_Expression (Ch); + Cond := Translate_Simple_String_Choice + (Expr_Node, + Chap7.Translate_Expression (Ch_Expr, + Get_Type (Ch_Expr)), + Val_Node, Tinfo, Func); + when Iir_Kind_Choice_By_Others => + Translate_Statements_Chain (Stmt_Chain); + return; + when others => + Error_Kind ("translate_string_choice", Ch); + end case; + if not First then + New_Assign_Stmt + (New_Obj (Cond_Var), + New_Dyadic_Op (ON_Or, New_Obj_Value (Cond_Var), Cond)); + end if; + Ch := Get_Chain (Ch); + exit when Ch = Null_Iir; + exit when not Get_Same_Alternative_Flag (Ch); + exit when Get_Associated (Ch) /= Null_Iir; + if First then + New_Assign_Stmt (New_Obj (Cond_Var), Cond); + First := False; + end if; + end loop; + if not First then + Cond := New_Obj_Value (Cond_Var); + end if; + Start_If_Stmt (If_Blk, Cond); + Translate_Statements_Chain (Stmt_Chain); + New_Else_Stmt (If_Blk); + Translate_String_Choice (Ch); + Finish_If_Stmt (If_Blk); + end Translate_String_Choice; + begin + Translate_String_Case_Statement_Common + (Stmt, Expr_Type, Tinfo, Expr_Node, Val_Node); Func := Chap7.Find_Predefined_Function - (Base_Type, Iir_Predefined_Array_Equality); + (Get_Base_Type (Expr_Type), Iir_Predefined_Array_Equality); - Choices_Chain := Get_Case_Statement_Alternative_Chain (Stmt); - Translate_String_Choice - (Expr_Node, C_Node, - Tinfo, Func, Cond_Var, Choices_Chain); - end Translate_String_Case_Statement; + Cond_Var := Create_Temp (Std_Boolean_Type_Node); + + Translate_String_Choice (Get_Case_Statement_Alternative_Chain (Stmt)); + end Translate_String_Case_Statement_Linear; procedure Translate_Case_Choice (Choice : Iir; Choice_Type : Iir; Blk : in out O_Case_Block) @@ -19045,7 +19490,30 @@ package body Translation is Expr := Get_Expression (Stmt); Expr_Type := Get_Type (Expr); if Get_Kind (Expr_Type) = Iir_Kind_Array_Subtype_Definition then - Translate_String_Case_Statement (Stmt); + declare + Nbr_Choices : Natural := 0; + Choice : Iir; + begin + Choice := Get_Case_Statement_Alternative_Chain (Stmt); + while Choice /= Null_Iir loop + case Get_Kind (Choice) is + when Iir_Kind_Choice_By_Others => + exit; + when Iir_Kind_Choice_By_Expression => + null; + when others => + raise Internal_Error; + end case; + Nbr_Choices := Nbr_Choices + 1; + Choice := Get_Chain (Choice); + end loop; + + if Nbr_Choices < 3 then + Translate_String_Case_Statement_Linear (Stmt); + else + Translate_String_Case_Statement_Dichotomy (Stmt); + end if; + end; return; end if; Start_Case_Stmt (Case_Blk, Chap7.Translate_Expression (Expr)); @@ -20950,6 +21418,313 @@ package body Translation is Info.Process_Parent_Field := Field; end Translate_Process_Declarations; + procedure Translate_Psl_Assert_Declarations (Stmt : Iir) + is + use PSL.Nodes; + use PSL.NFAs; + + Mark : Id_Mark_Type; + Info : Ortho_Info_Acc; + Itype : O_Tnode; + Field : O_Fnode; + + N : NFA; + begin + -- Create process record. + Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); + Push_Instance_Factory (O_Tnode_Null); + Info := Add_Info (Stmt, Kind_Psl_Assert); + + N := Get_PSL_NFA (Stmt); + Labelize_States (N, Info.Psl_Vect_Len); + Info.Psl_Vect_Type := New_Constrained_Array_Type + (Std_Boolean_Array_Type, + New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Info.Psl_Vect_Len))); + New_Type_Decl (Create_Identifier ("VECTTYPE"), Info.Psl_Vect_Type); + Info.Psl_Vect_Var := + Create_Var (Create_Var_Identifier ("VECT"), Info.Psl_Vect_Type); + + Pop_Instance_Factory (Itype); + New_Type_Decl (Create_Identifier ("INSTTYPE"), Itype); + Pop_Identifier_Prefix (Mark); + + -- Create a field in the parent record. + Field := Add_Instance_Factory_Field + (Create_Identifier_Without_Prefix (Stmt), Itype); + + -- Set info in child record. + Info.Psl_Decls_Type := Itype; + Info.Psl_Parent_Field := Field; + end Translate_Psl_Assert_Declarations; + + function Translate_Psl_Expr (Expr : PSL_Node; Eos : Boolean) + return O_Enode + is + use PSL.Nodes; + begin + case Get_Kind (Expr) is + when N_HDL_Expr => + declare + E : Iir; + Rtype : Iir; + Res : O_Enode; + begin + E := Get_HDL_Node (Expr); + Rtype := Get_Base_Type (Get_Type (E)); + Res := Chap7.Translate_Expression (E); + if Rtype = Boolean_Type_Definition then + return Res; + elsif Rtype = Ieee.Std_Logic_1164.Std_Ulogic_Type then + return New_Value + (New_Indexed_Element + (New_Obj (Ghdl_Std_Ulogic_To_Boolean_Array), + New_Convert_Ov (Res, Ghdl_Index_Type))); + else + Error_Kind ("translate_psl_expr/hdl_expr", Expr); + end if; + end; + when N_True => + return New_Lit (Std_Boolean_True_Node); + when N_EOS => + if Eos then + return New_Lit (Std_Boolean_True_Node); + else + return New_Lit (Std_Boolean_False_Node); + end if; + when N_Not_Bool => + return New_Monadic_Op + (ON_Not, + Translate_Psl_Expr (Get_Boolean (Expr), Eos)); + when N_And_Bool => + return New_Dyadic_Op + (ON_And, + Translate_Psl_Expr (Get_Left (Expr), Eos), + Translate_Psl_Expr (Get_Right (Expr), Eos)); + when N_Or_Bool => + return New_Dyadic_Op + (ON_Or, + Translate_Psl_Expr (Get_Left (Expr), Eos), + Translate_Psl_Expr (Get_Right (Expr), Eos)); + when others => + Error_Kind ("translate_psl_expr", Expr); + end case; + end Translate_Psl_Expr; + + -- Return TRUE iff NFA has an edge with an EOS. + -- If so, we need to create a finalizer. + function Psl_Need_Finalizer (Nfa : PSL_NFA) return Boolean + is + use PSL.NFAs; + S : NFA_State; + E : NFA_Edge; + begin + S := Get_Final_State (Nfa); + E := Get_First_Dest_Edge (S); + while E /= No_Edge loop + if PSL.NFAs.Utils.Has_EOS (Get_Edge_Expr (E)) then + return True; + end if; + E := Get_Next_Dest_Edge (E); + end loop; + return False; + end Psl_Need_Finalizer; + + procedure Translate_Psl_Assert_Statement + (Stmt : Iir; Base : Block_Info_Acc) + is + use PSL.NFAs; + Inter_List : O_Inter_List; + Instance : O_Dnode; + Info : Psl_Info_Acc; + Var_I : O_Dnode; + Var_Nvec : O_Dnode; + Label : O_Snode; + Clk_Blk : O_If_Block; + S_Blk : O_If_Block; + E_Blk : O_If_Block; + S : NFA_State; + S_Num : Int32; + E : NFA_Edge; + Sd : NFA_State; + Cond : O_Enode; + NFA : PSL_NFA; + D_Lit : O_Cnode; + begin + Info := Get_Info (Stmt); + Start_Procedure_Decl (Inter_List, Create_Identifier ("PROC"), + O_Storage_Private); + New_Interface_Decl (Inter_List, Instance, Wki_Instance, + Base.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Inter_List, Info.Psl_Proc_Subprg); + + Start_Subprogram_Body (Info.Psl_Proc_Subprg); + Push_Local_Factory; + -- Push scope for architecture declarations. + Push_Scope (Base.Block_Decls_Type, Instance); + + -- New state vector. + New_Var_Decl (Var_Nvec, Wki_Res, O_Storage_Local, Info.Psl_Vect_Type); + + -- Initialize the new state vector. + Start_Declare_Stmt; + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, + New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I), + New_Lit (New_Unsigned_Literal + (Ghdl_Index_Type, + Unsigned_64 (Info.Psl_Vect_Len))), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Indexed_Element (New_Obj (Var_Nvec), + New_Obj_Value (Var_I)), + New_Lit (Std_Boolean_False_Node)); + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Finish_Declare_Stmt; + + -- Global if statement for the clock. + Open_Temp; + Start_If_Stmt (Clk_Blk, + Translate_Psl_Expr (Get_PSL_Clock (Stmt), False)); + + -- For each state: if set, evaluate all outgoing edges. + NFA := Get_PSL_NFA (Stmt); + S := Get_First_State (NFA); + while S /= No_State loop + S_Num := Get_State_Label (S); + Open_Temp; + + Start_If_Stmt + (S_Blk, + New_Value + (New_Indexed_Element (Get_Var (Info.Psl_Vect_Var), + New_Lit (New_Index_Lit + (Unsigned_64 (S_Num)))))); + + E := Get_First_Src_Edge (S); + while E /= No_Edge loop + Sd := Get_Edge_Dest (E); + Open_Temp; + + D_Lit := New_Index_Lit (Unsigned_64 (Get_State_Label (Sd))); + Cond := New_Monadic_Op + (ON_Not, + New_Value (New_Indexed_Element (New_Obj (Var_Nvec), + New_Lit (D_Lit)))); + Cond := New_Dyadic_Op + (ON_And, Cond, Translate_Psl_Expr (Get_Edge_Expr (E), False)); + Start_If_Stmt (E_Blk, Cond); + New_Assign_Stmt + (New_Indexed_Element (New_Obj (Var_Nvec), New_Lit (D_Lit)), + New_Lit (Std_Boolean_True_Node)); + Finish_If_Stmt (E_Blk); + + Close_Temp; + E := Get_Next_Src_Edge (E); + end loop; + + Finish_If_Stmt (S_Blk); + Close_Temp; + S := Get_Next_State (S); + end loop; + + -- Check fail state. + S := Get_Final_State (NFA); + S_Num := Get_State_Label (S); + pragma Assert (Integer (S_Num) = Info.Psl_Vect_Len - 1); + Start_If_Stmt + (S_Blk, + New_Value + (New_Indexed_Element (New_Obj (Var_Nvec), + New_Lit (New_Index_Lit + (Unsigned_64 (S_Num)))))); + Chap8.Translate_Report + (Stmt, Ghdl_Psl_Assert_Failed, Severity_Level_Error); + Finish_If_Stmt (S_Blk); + + -- Assign state vector. + Start_Declare_Stmt; + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, + New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I), + New_Lit (New_Unsigned_Literal + (Ghdl_Index_Type, + Unsigned_64 (Info.Psl_Vect_Len))), + Ghdl_Bool_Type)); + New_Assign_Stmt + (New_Indexed_Element (Get_Var (Info.Psl_Vect_Var), + New_Obj_Value (Var_I)), + New_Value (New_Indexed_Element (New_Obj (Var_Nvec), + New_Obj_Value (Var_I)))); + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Finish_Declare_Stmt; + + Close_Temp; + Finish_If_Stmt (Clk_Blk); + + Pop_Scope (Base.Block_Decls_Type); + Pop_Local_Factory; + Finish_Subprogram_Body; + + -- The finalizer. + if Psl_Need_Finalizer (NFA) then + Start_Procedure_Decl (Inter_List, Create_Identifier ("FINALPROC"), + O_Storage_Private); + New_Interface_Decl (Inter_List, Instance, Wki_Instance, + Base.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Inter_List, Info.Psl_Proc_Final_Subprg); + + Start_Subprogram_Body (Info.Psl_Proc_Final_Subprg); + Push_Local_Factory; + -- Push scope for architecture declarations. + Push_Scope (Base.Block_Decls_Type, Instance); + + S := Get_Final_State (NFA); + E := Get_First_Dest_Edge (S); + while E /= No_Edge loop + Sd := Get_Edge_Src (E); + + if PSL.NFAs.Utils.Has_EOS (Get_Edge_Expr (E)) then + + S_Num := Get_State_Label (Sd); + Open_Temp; + + Cond := New_Value + (New_Indexed_Element + (Get_Var (Info.Psl_Vect_Var), + New_Lit (New_Index_Lit (Unsigned_64 (S_Num))))); + Cond := New_Dyadic_Op + (ON_And, Cond, + Translate_Psl_Expr (Get_Edge_Expr (E), True)); + Start_If_Stmt (E_Blk, Cond); + Chap8.Translate_Report + (Stmt, Ghdl_Psl_Assert_Failed, Severity_Level_Error); + New_Return_Stmt; + Finish_If_Stmt (E_Blk); + + Close_Temp; + end if; + + E := Get_Next_Dest_Edge (E); + end loop; + + Pop_Scope (Base.Block_Decls_Type); + Pop_Local_Factory; + Finish_Subprogram_Body; + else + Info.Psl_Proc_Final_Subprg := O_Dnode_Null; + end if; + end Translate_Psl_Assert_Statement; + -- Create the instance for block BLOCK. -- BLOCK can be either an entity, an architecture or a block statement. procedure Translate_Block_Declarations (Block : Iir; Origin : Iir) @@ -20964,6 +21739,12 @@ package body Translation is when Iir_Kind_Process_Statement | Iir_Kind_Sensitized_Process_Statement => Translate_Process_Declarations (El); + when Iir_Kind_Psl_Default_Clock => + null; + when Iir_Kind_Psl_Declaration => + null; + when Iir_Kind_Psl_Assert_Statement => + Translate_Psl_Assert_Declarations (El); when Iir_Kind_Component_Instantiation_Statement => Translate_Component_Instantiation_Statement (El); when Iir_Kind_Block_Statement => @@ -21191,6 +21972,21 @@ package body Translation is end if; Pop_Scope (Info.Process_Decls_Type); end; + when Iir_Kind_Psl_Default_Clock => + null; + when Iir_Kind_Psl_Declaration => + null; + when Iir_Kind_Psl_Assert_Statement => + declare + Info : Psl_Info_Acc; + begin + Info := Get_Info (Stmt); + Push_Scope (Info.Psl_Decls_Type, + Info.Psl_Parent_Field, + Block_Info.Block_Decls_Type); + Translate_Psl_Assert_Statement (Stmt, Base_Info); + Pop_Scope (Info.Psl_Decls_Type); + end; when Iir_Kind_Component_Instantiation_Statement => Chap4.Translate_Association_Subprograms (Stmt, Block, Base_Block, @@ -21511,6 +22307,89 @@ package body Translation is Pop_Scope (Info.Process_Decls_Type); end Elab_Process; + -- PROC: the process to be elaborated + -- BLOCK_INFO: info for the block containing the process + -- BASE_INFO: info for the global block + procedure Elab_Psl_Assert (Stmt : Iir; + Block_Info : Block_Info_Acc; + Base_Info : Block_Info_Acc) + is + Constr : O_Assoc_List; + Info : Psl_Info_Acc; + List : Iir_List; + Clk : PSL_Node; + Var_I : O_Dnode; + Label : O_Snode; + begin + New_Debug_Line_Stmt (Get_Line_Number (Stmt)); + + Info := Get_Info (Stmt); + + -- Set instance name. + Push_Scope (Info.Psl_Decls_Type, + Info.Psl_Parent_Field, + Block_Info.Block_Decls_Type); + + -- Register process. + Start_Association (Constr, Ghdl_Sensitized_Process_Register); + New_Association + (Constr, New_Unchecked_Address + (Get_Instance_Ref (Base_Info.Block_Decls_Type), Ghdl_Ptr_Type)); + New_Association + (Constr, + New_Lit (New_Subprogram_Address (Info.Psl_Proc_Subprg, + Ghdl_Ptr_Type))); + Rtis.Associate_Rti_Context (Constr, Stmt); + New_Procedure_Call (Constr); + + -- Register clock sensitivity. + Clk := Get_PSL_Clock (Stmt); + List := Create_Iir_List; + Canon_PSL.Canon_Extract_Sensitivity (Clk, List); + Destroy_Types_In_List (List); + Register_Signal_List (List, Ghdl_Process_Add_Sensitivity); + Destroy_Iir_List (List); + + -- Register finalizer (if any). + if Info.Psl_Proc_Final_Subprg /= O_Dnode_Null then + Start_Association (Constr, Ghdl_Finalize_Register); + New_Association + (Constr, New_Unchecked_Address + (Get_Instance_Ref (Base_Info.Block_Decls_Type), + Ghdl_Ptr_Type)); + New_Association + (Constr, + New_Lit (New_Subprogram_Address (Info.Psl_Proc_Final_Subprg, + Ghdl_Ptr_Type))); + New_Procedure_Call (Constr); + end if; + + -- Initialize state vector. + Start_Declare_Stmt; + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + New_Assign_Stmt (New_Indexed_Element (Get_Var (Info.Psl_Vect_Var), + New_Lit (Ghdl_Index_0)), + New_Lit (Std_Boolean_True_Node)); + New_Assign_Stmt (New_Obj (Var_I), New_Lit (Ghdl_Index_1)); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, + New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I), + New_Lit (New_Unsigned_Literal + (Ghdl_Index_Type, + Unsigned_64 (Info.Psl_Vect_Len))), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Indexed_Element (Get_Var (Info.Psl_Vect_Var), + New_Obj_Value (Var_I)), + New_Lit (Std_Boolean_False_Node)); + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Finish_Declare_Stmt; + + Pop_Scope (Info.Psl_Decls_Type); + end Elab_Psl_Assert; + procedure Elab_Implicit_Guard_Signal (Block : Iir_Block_Statement; Block_Info : Block_Info_Acc) is @@ -22178,6 +23057,12 @@ package body Translation is when Iir_Kind_Process_Statement | Iir_Kind_Sensitized_Process_Statement => Elab_Process (Stmt, Block_Info, Base_Info); + when Iir_Kind_Psl_Default_Clock => + null; + when Iir_Kind_Psl_Declaration => + null; + when Iir_Kind_Psl_Assert_Statement => + Elab_Psl_Assert (Stmt, Block_Info, Base_Info); when Iir_Kind_Component_Instantiation_Statement => declare Info : Block_Info_Acc; @@ -24455,6 +25340,10 @@ package body Translation is (Constr, Get_Identifier ("__ghdl_rtik_attribute_stable"), Ghdl_Rtik_Attribute_Stable); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_psl_assert"), + Ghdl_Rtik_Psl_Assert); + New_Enum_Literal (Constr, Get_Identifier ("__ghdl_rtik_error"), Ghdl_Rtik_Error); Finish_Enum_Type (Constr, Ghdl_Rtik); @@ -25205,6 +26094,8 @@ package body Translation is case Info.Type_Mode is when Type_Mode_I32 => Kind := Ghdl_Rtik_Type_I32; + when Type_Mode_I64 => + Kind := Ghdl_Rtik_Type_I64; when Type_Mode_F64 => Kind := Ghdl_Rtik_Type_F64; when Type_Mode_P64 => @@ -26320,6 +27211,37 @@ package body Translation is Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); Generate_Instance (Stmt, Parent_Rti); Pop_Identifier_Prefix (Mark); + when Iir_Kind_Psl_Default_Clock => + null; + when Iir_Kind_Psl_Declaration => + null; + when Iir_Kind_Psl_Assert_Statement => + declare + Name : O_Dnode; + List : O_Record_Aggr_List; + + Rti : O_Dnode; + Res : O_Cnode; + Info : Psl_Info_Acc; + begin + Info := Get_Info (Stmt); + Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); + Name := Generate_Name (Stmt); + + New_Const_Decl (Rti, Create_Identifier ("RTI"), + O_Storage_Public, Ghdl_Rtin_Type_Scalar); + + Start_Const_Value (Rti); + Start_Record_Aggr (List, Ghdl_Rtin_Type_Scalar); + New_Record_Aggr_El + (List, Generate_Common (Ghdl_Rtik_Psl_Assert)); + New_Record_Aggr_El + (List, New_Global_Address (Name, Char_Ptr_Type)); + Finish_Record_Aggr (List, Res); + Finish_Const_Value (Rti, Res); + Info.Psl_Rti_Const := Rti; + Pop_Identifier_Prefix (Mark); + end; when others => Error_Kind ("rti.generate_concurrent_statement_chain", Stmt); end case; @@ -26710,6 +27632,8 @@ package body Translation is when Iir_Kind_Process_Statement | Iir_Kind_Sensitized_Process_Statement => Rti_Const := Node_Info.Process_Rti_Const; + when Iir_Kind_Psl_Assert_Statement => + Rti_Const := Node_Info.Psl_Rti_Const; when others => Error_Kind ("get_context_rti", Node); end case; @@ -26738,6 +27662,8 @@ package body Translation is when Iir_Kind_Process_Statement | Iir_Kind_Sensitized_Process_Statement => Block_Type := Node_Info.Process_Decls_Type; + when Iir_Kind_Psl_Assert_Statement => + Block_Type := Node_Info.Psl_Decls_Type; when others => Error_Kind ("get_context_addr", Node); end case; @@ -26935,8 +27861,6 @@ package body Translation is Wki_Right := Get_Identifier ("right"); Wki_Dir := Get_Identifier ("dir"); Wki_Length := Get_Identifier ("length"); - Wki_Kind := Get_Identifier ("kind"); - Wki_Dim := Get_Identifier ("dim"); Wki_I := Get_Identifier ("I"); Wki_Instance := Get_Identifier ("INSTANCE"); Wki_Arch_Instance := Get_Identifier ("ARCH_INSTANCE"); @@ -26947,6 +27871,10 @@ package body Translation is Wki_Parent := Get_Identifier ("parent"); Wki_Filename := Get_Identifier ("filename"); Wki_Line := Get_Identifier ("line"); + Wki_Lo := Get_Identifier ("lo"); + Wki_Hi := Get_Identifier ("hi"); + Wki_Mid := Get_Identifier ("mid"); + Wki_Cmp := Get_Identifier ("cmp"); Sizetype := New_Unsigned_Type (32); New_Type_Decl (Get_Identifier ("__ghdl_size_type"), Sizetype); @@ -27296,6 +28224,15 @@ package body Translation is ("__ghdl_postponed_sensitized_process_register", Ghdl_Postponed_Sensitized_Process_Register); end; + + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_finalize_register"), + O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Wki_This, Ghdl_Ptr_Type); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("proc"), Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Finalize_Register); end Initialize; procedure Create_Signal_Subprograms @@ -27486,6 +28423,8 @@ package body Translation is end Create_Report_Subprg; begin Create_Report_Subprg ("__ghdl_assert_failed", Ghdl_Assert_Failed); + Create_Report_Subprg ("__ghdl_psl_assert_failed", + Ghdl_Psl_Assert_Failed); Create_Report_Subprg ("__ghdl_report", Ghdl_Report); end; @@ -28260,6 +29199,10 @@ package body Translation is Std_Boolean_True_Node := Get_Ortho_Expr (Boolean_True); Std_Boolean_False_Node := Get_Ortho_Expr (Boolean_False); + Std_Boolean_Array_Type := + New_Array_Type (Std_Boolean_Type_Node, Ghdl_Index_Type); + New_Type_Decl (Create_Identifier ("BOOLEAN_ARRAY"), + Std_Boolean_Array_Type); Chap4.Translate_Bool_Type_Declaration (Bit_Type); Chap4.Translate_Type_Declaration (Character_Type); @@ -28337,6 +29280,16 @@ package body Translation is := Get_Info (Bit_Type_Definition).Type_Rti; end if; + -- Std_Ulogic indexed array of STD.Boolean. + -- Used by PSL to convert Std_Ulogic to boolean. + Std_Ulogic_Boolean_Array_Type := + New_Constrained_Array_Type (Std_Boolean_Array_Type, New_Index_Lit (9)); + New_Type_Decl (Get_Identifier ("__ghdl_std_ulogic_boolean_array_type"), + Std_Ulogic_Boolean_Array_Type); + New_Const_Decl (Ghdl_Std_Ulogic_To_Boolean_Array, + Get_Identifier ("__ghdl_std_ulogic_to_boolean_array"), + O_Storage_External, Std_Ulogic_Boolean_Array_Type); + Pop_Identifier_Prefix (Unit_Mark); Pop_Identifier_Prefix (Lib_Mark); |