From 401341a2c5f2533ff68aae9dd4e65bb297c36679 Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Fri, 26 Jul 2019 18:49:59 +0200 Subject: vhdl: linearize analyze and evaluation of concat operators. --- src/vhdl/vhdl-evaluation.adb | 341 +++++++++++++++-------- src/vhdl/vhdl-evaluation.ads | 6 + src/vhdl/vhdl-nodes.ads | 1 + src/vhdl/vhdl-nodes_meta.adb | 14 +- src/vhdl/vhdl-sem_expr.adb | 645 +++++++++++++++++++++++++++---------------- 5 files changed, 647 insertions(+), 360 deletions(-) diff --git a/src/vhdl/vhdl-evaluation.adb b/src/vhdl/vhdl-evaluation.adb index 52b489816..1b5232767 100644 --- a/src/vhdl/vhdl-evaluation.adb +++ b/src/vhdl/vhdl-evaluation.adb @@ -997,126 +997,157 @@ package body Vhdl.Evaluation is return Build_Simple_Aggregate (Res_List, Origin, Get_Type (Left)); end Eval_Shift_Operator; - -- Note: operands must be locally static. - function Eval_Concatenation - (Left, Right : Iir; Orig : Iir; Func : Iir_Predefined_Concat_Functions) - return Iir + -- Concatenate all the elements of OPERANDS. + -- The first element of OPERANDS is the rightest one, the last the + -- leftest one. All the elements are concatenation operators. + -- All the elements are static. + function Eval_Concatenation (Operands : Iir_Array) return Iir is + pragma Assert (Operands'First = 1); + Orig : constant Iir := Operands (1); + Origin_Type : constant Iir := Get_Type (Orig); + + Ops_Val : Iir_Array (Operands'Range); + Str_Lits : Iir_Array (Operands'Range); + Left_Op : Iir; + Left_Val : Iir; + Left_Lit : Iir; Res_List : Iir_Flist; Res_Len : Natural; Res_Type : Iir; - Origin_Type : Iir; - Left_Aggr, Right_Aggr : Iir; - Left_List, Right_List : Iir_Flist; - Left_Len, Right_Len : Natural; + Def, Left_Def : Iir_Predefined_Functions; + Op : Iir; + El : Iir; + El_List : Iir_Flist; + El_Len : Natural; + Err_Orig : Iir; + + -- To compute the index range of the result for vhdl87. + Leftest_Non_Null : Iir; + Bounds_From_Subtype : Boolean; begin - -- Compute length of the result. - -- Left: - case Func is - when Iir_Predefined_Element_Array_Concat - | Iir_Predefined_Element_Element_Concat => - Left_Len := 1; - when Iir_Predefined_Array_Element_Concat - | Iir_Predefined_Array_Array_Concat => - Left_Aggr := Eval_String_Literal (Left); - Left_List := Get_Simple_Aggregate_List (Left_Aggr); - Left_Len := Get_Nbr_Elements (Left_List); - end case; - -- Right: - case Func is - when Iir_Predefined_Array_Element_Concat - | Iir_Predefined_Element_Element_Concat => - Right_Len := 1; - when Iir_Predefined_Element_Array_Concat - | Iir_Predefined_Array_Array_Concat => - Right_Aggr := Eval_String_Literal (Right); - Right_List := Get_Simple_Aggregate_List (Right_Aggr); - Right_Len := Get_Nbr_Elements (Right_List); - end case; + -- Eval operands, compute length of the result. + Err_Orig := Null_Iir; + Res_Len := 0; + for I in Operands'Range loop + Op := Operands (I); + Def := Get_Implicit_Definition (Get_Implementation (Op)); + if Get_Kind (Op) = Iir_Kind_Function_Call then + El := Get_Actual + (Get_Chain (Get_Parameter_Association_Chain (Op))); + else + El := Get_Right (Op); + end if; + Ops_Val (I) := Eval_Static_Expr (El); + if Get_Kind (Ops_Val (I)) = Iir_Kind_Overflow_Literal then + Err_Orig := El; + else + case Iir_Predefined_Concat_Functions (Def) is + when Iir_Predefined_Array_Element_Concat + | Iir_Predefined_Element_Element_Concat => + Res_Len := Res_Len + 1; + when Iir_Predefined_Element_Array_Concat + | Iir_Predefined_Array_Array_Concat => + Str_Lits (I) := Eval_String_Literal (Ops_Val (I)); + El_List := Get_Simple_Aggregate_List (Str_Lits (I)); + Res_Len := Res_Len + Get_Nbr_Elements (El_List); + end case; + end if; + end loop; + + Op := Operands (Operands'Last); + if Get_Kind (Op) = Iir_Kind_Function_Call then + Left_Op := Get_Actual (Get_Parameter_Association_Chain (Op)); + else + Left_Op := Get_Left (Op); + end if; + Left_Val := Eval_Static_Expr (Left_Op); + if Get_Kind (Left_Val) = Iir_Kind_Overflow_Literal then + Err_Orig := Left_Op; + else + Left_Def := Def; + case Iir_Predefined_Concat_Functions (Left_Def) is + when Iir_Predefined_Element_Array_Concat + | Iir_Predefined_Element_Element_Concat => + Res_Len := Res_Len + 1; + when Iir_Predefined_Array_Element_Concat + | Iir_Predefined_Array_Array_Concat => + Left_Lit := Eval_String_Literal (Left_Val); + El_List := Get_Simple_Aggregate_List (Left_Lit); + Res_Len := Res_Len + Get_Nbr_Elements (El_List); + end case; + end if; + + -- Handle overflow. + if Err_Orig /= Null_Iir then + -- Free all. + for I in Ops_Val'Range loop + Free_Eval_Static_Expr (Ops_Val (I), Operands (I)); + end loop; + Free_Eval_Static_Expr (Left_Val, Left_Op); + + return Build_Overflow (Err_Orig); + end if; - Res_Len := Left_Len + Right_Len; Res_List := Create_Iir_Flist (Res_Len); + -- Do the concatenation. -- Left: - case Func is + Leftest_Non_Null := Null_Iir; + case Iir_Predefined_Concat_Functions (Left_Def) is when Iir_Predefined_Element_Array_Concat | Iir_Predefined_Element_Element_Concat => - Set_Nth_Element (Res_List, 0, Left); + Set_Nth_Element (Res_List, 0, Left_Val); + Bounds_From_Subtype := True; + Res_Len := 1; when Iir_Predefined_Array_Element_Concat | Iir_Predefined_Array_Array_Concat => - for I in 0 .. Left_Len - 1 loop - Set_Nth_Element (Res_List, I, Get_Nth_Element (Left_List, I)); + El_List := Get_Simple_Aggregate_List (Left_Lit); + Res_Len := Get_Nbr_Elements (El_List); + for I in 0 .. Res_Len - 1 loop + Set_Nth_Element (Res_List, I, Get_Nth_Element (El_List, I)); end loop; - Free_Eval_String_Literal (Left_Aggr, Left); + Bounds_From_Subtype := Def = Iir_Predefined_Array_Element_Concat; + if Res_Len > 0 then + Leftest_Non_Null := Get_Type (Left_Lit); + end if; + Free_Eval_String_Literal (Left_Lit, Left_Val); end case; + -- Right: - case Func is - when Iir_Predefined_Array_Element_Concat - | Iir_Predefined_Element_Element_Concat => - Set_Nth_Element (Res_List, Left_Len, Right); - when Iir_Predefined_Element_Array_Concat - | Iir_Predefined_Array_Array_Concat => - for I in 0 .. Right_Len - 1 loop - Set_Nth_Element - (Res_List, Left_Len + I, Get_Nth_Element (Right_List, I)); - end loop; - Free_Eval_String_Literal (Right_Aggr, Right); - end case; + for I in reverse Operands'Range loop + Def := Get_Implicit_Definition (Get_Implementation (Operands (I))); + case Iir_Predefined_Concat_Functions (Def) is + when Iir_Predefined_Array_Element_Concat + | Iir_Predefined_Element_Element_Concat => + Set_Nth_Element (Res_List, Res_Len, Ops_Val (I)); + Bounds_From_Subtype := True; + Res_Len := Res_Len + 1; + when Iir_Predefined_Element_Array_Concat + | Iir_Predefined_Array_Array_Concat => + El_List := Get_Simple_Aggregate_List (Str_Lits (I)); + El_Len := Get_Nbr_Elements (El_List); + for I in 0 .. El_Len - 1 loop + Set_Nth_Element + (Res_List, Res_Len + I, Get_Nth_Element (El_List, I)); + end loop; + Bounds_From_Subtype := Bounds_From_Subtype + or Def = Iir_Predefined_Element_Array_Concat; + if Leftest_Non_Null = Null_Iir and then El_Len /= 0 then + Leftest_Non_Null := Get_Type (Ops_Val (I)); + end if; + Free_Eval_String_Literal (Str_Lits (I), Ops_Val (I)); + Res_Len := Res_Len + El_Len; + end case; + end loop; -- Compute subtype... - Origin_Type := Get_Type (Orig); - Res_Type := Null_Iir; - if Func = Iir_Predefined_Array_Array_Concat - and then Left_Len = 0 - then - if Flags.Vhdl_Std = Vhdl_87 then - -- LRM87 7.2.3 - -- [...], unless the left operand is a null array, in which case - -- the result of the concatenation is the right operand. - Res_Type := Get_Type (Right); - else - -- LRM93 7.2.4 - -- If both operands are null arrays, then the result of the - -- concatenation is the right operand. - if Get_Nbr_Elements (Right_List) = 0 then - Res_Type := Get_Type (Right); - end if; - end if; - end if; - if Res_Type = Null_Iir then - if Flags.Vhdl_Std = Vhdl_87 - and then (Func = Iir_Predefined_Array_Array_Concat - or Func = Iir_Predefined_Array_Element_Concat) - then - -- LRM87 7.2.3 - -- The left bound of the result is the left operand, [...] - -- - -- LRM87 7.2.3 - -- The direction of the result is the direction of the left - -- operand, [...] - declare - Left_Index : constant Iir := - Get_Index_Type (Get_Type (Left), 0); - Left_Range : constant Iir := - Get_Range_Constraint (Left_Index); - Ret_Type : constant Iir := - Get_Return_Type (Get_Implementation (Orig)); - A_Range : Iir; - Index_Type : Iir; - begin - A_Range := Create_Iir (Iir_Kind_Range_Expression); - Set_Type (A_Range, Get_Index_Type (Ret_Type, 0)); - Set_Expr_Staticness (A_Range, Locally); - Set_Left_Limit (A_Range, Get_Left_Limit (Left_Range)); - Set_Direction (A_Range, Get_Direction (Left_Range)); - Location_Copy (A_Range, Orig); - Set_Right_Limit_By_Length (A_Range, Int64 (Res_Len)); - Index_Type := Create_Range_Subtype_From_Type - (Left_Index, Get_Location (Orig)); - Set_Range_Constraint (Index_Type, A_Range); - Res_Type := Create_Unidim_Array_From_Index - (Origin_Type, Index_Type, Orig); - end; + if Flags.Vhdl_Std > Vhdl_87 then + -- LRM93 7.2.4 + -- If both operands are null arrays, then the result of the + -- concatenation is the right operand. + if Res_Len = 0 then + Res_Type := Get_Type (Get_Right (Operands (1))); else -- LRM93 7.2.4 -- Otherwise, the direction and bounds of the result are @@ -1127,7 +1158,63 @@ package body Vhdl.Evaluation is Res_Type := Create_Unidim_Array_By_Length (Origin_Type, Int64 (Res_Len), Orig); end if; + else + -- LRM87 7.2.3 + -- The left bound of the result is the left operand, [...] + -- + -- LRM87 7.2.3 + -- The direction of the result is the direction of the left + -- operand, [...] + -- + -- LRM87 7.2.3 + -- [...], unless the left operand is a null array, in which case + -- the result of the concatenation is the right operand. + + -- Look for the first operand that is either an element or + -- a non-null array. If it is an element, create the bounds + -- by length. If it is an array, create the bounds from it. If + -- there is no such operand, use the leftest operands for the + -- bounds. + if Bounds_From_Subtype then + -- There is at least one concatenation with an element. + Res_Type := Create_Unidim_Array_By_Length + (Origin_Type, Int64 (Res_Len), Orig); + else + if Res_Len = 0 then + Res_Type := Get_Type (Get_Right (Operands (1))); + else + declare + Left_Index : constant Iir := + Get_Index_Type (Leftest_Non_Null, 0); + Left_Range : constant Iir := + Get_Range_Constraint (Left_Index); + Ret_Type : constant Iir := + Get_Return_Type (Get_Implementation (Orig)); + A_Range : Iir; + Index_Type : Iir; + begin + A_Range := Create_Iir (Iir_Kind_Range_Expression); + Set_Type (A_Range, Get_Index_Type (Ret_Type, 0)); + Set_Expr_Staticness (A_Range, Locally); + Set_Left_Limit (A_Range, Get_Left_Limit (Left_Range)); + Set_Direction (A_Range, Get_Direction (Left_Range)); + Location_Copy (A_Range, Orig); + Set_Right_Limit_By_Length (A_Range, Int64 (Res_Len)); + Index_Type := Create_Range_Subtype_From_Type + (Left_Index, Get_Location (Orig)); + Set_Range_Constraint (Index_Type, A_Range); + Res_Type := Create_Unidim_Array_From_Index + (Origin_Type, Index_Type, Orig); + end; + end if; + end if; end if; + + for I in Ops_Val'Range loop + Free_Eval_Static_Expr (Ops_Val (I), Operands (I)); + end loop; + Free_Eval_Static_Expr (Left_Val, Left_Op); + -- FIXME: this is not necessarily a string, it may be an aggregate if -- element type is not a character type. return Build_Simple_Aggregate (Res_List, Orig, Res_Type, Res_Type); @@ -1284,7 +1371,7 @@ package body Vhdl.Evaluation is -- ORIG is either a dyadic operator or a function call. function Eval_Dyadic_Operator (Orig : Iir; Imp : Iir; Left, Right : Iir) - return Iir + return Iir is pragma Unsuppress (Overflow_Check); Func : constant Iir_Predefined_Functions := @@ -1496,7 +1583,7 @@ package body Vhdl.Evaluation is | Iir_Predefined_Array_Element_Concat | Iir_Predefined_Array_Array_Concat | Iir_Predefined_Element_Element_Concat => - return Eval_Concatenation (Left, Right, Orig, Func); + raise Internal_Error; when Iir_Predefined_Enum_Equality | Iir_Predefined_Bit_Match_Equality => @@ -2631,21 +2718,27 @@ package body Vhdl.Evaluation is end; when Iir_Kinds_Dyadic_Operator => declare + Imp : constant Iir := Get_Implementation (Expr); Left : constant Iir := Get_Left (Expr); Right : constant Iir := Get_Right (Expr); Left_Val, Right_Val : Iir; Res : Iir; begin - Left_Val := Eval_Static_Expr (Left); - Right_Val := Eval_Static_Expr (Right); + if (Get_Implicit_Definition (Imp) + in Iir_Predefined_Concat_Functions) + then + return Eval_Concatenation ((1 => Expr)); + else + Left_Val := Eval_Static_Expr (Left); + Right_Val := Eval_Static_Expr (Right); - Res := Eval_Dyadic_Operator - (Expr, Get_Implementation (Expr), Left_Val, Right_Val); + Res := Eval_Dyadic_Operator (Expr, Imp, Left_Val, Right_Val); - Free_Eval_Static_Expr (Left_Val, Left); - Free_Eval_Static_Expr (Right_Val, Right); + Free_Eval_Static_Expr (Left_Val, Left); + Free_Eval_Static_Expr (Right_Val, Right); - return Res; + return Res; + end if; end; when Iir_Kind_Attribute_Name => @@ -2874,16 +2967,22 @@ package body Vhdl.Evaluation is Imp : constant Iir := Get_Implementation (Expr); Left, Right : Iir; begin - -- Note: there can't be association by name. - Left := Get_Parameter_Association_Chain (Expr); - Right := Get_Chain (Left); - - Left := Eval_Static_Expr (Get_Actual (Left)); - if Right = Null_Iir then - return Eval_Monadic_Operator (Expr, Left); + if (Get_Implicit_Definition (Imp) + in Iir_Predefined_Concat_Functions) + then + return Eval_Concatenation ((1 => Expr)); else - Right := Eval_Static_Expr (Get_Actual (Right)); - return Eval_Dyadic_Operator (Expr, Imp, Left, Right); + -- Note: there can't be association by name. + Left := Get_Parameter_Association_Chain (Expr); + Right := Get_Chain (Left); + + Left := Eval_Static_Expr (Get_Actual (Left)); + if Right = Null_Iir then + return Eval_Monadic_Operator (Expr, Left); + else + Right := Eval_Static_Expr (Get_Actual (Right)); + return Eval_Dyadic_Operator (Expr, Imp, Left, Right); + end if; end if; end; @@ -2982,7 +3081,7 @@ package body Vhdl.Evaluation is end Can_Eval_Value; -- For composite values. - -- Evluating a composite value is a trade-off: it can simplify the + -- Evaluating a composite value is a trade-off: it can simplify the -- generated code if the value is small enough, or it can be a bad idea if -- the value is very large. It is very easy to create large static -- composite values (like: bit_vector'(1 to 10**4 => '0')) diff --git a/src/vhdl/vhdl-evaluation.ads b/src/vhdl/vhdl-evaluation.ads index 48a36a886..bf63abb49 100644 --- a/src/vhdl/vhdl-evaluation.ads +++ b/src/vhdl/vhdl-evaluation.ads @@ -66,6 +66,12 @@ package Vhdl.Evaluation is -- is locally static. function Eval_Expr_If_Static (Expr : Iir) return Iir; + -- Concatenate all the elements of OPERANDS. + -- The first element of OPERANDS is the rightest one, the last the + -- leftest one. All the elements are concatenation operators. + -- All the elements are static. + function Eval_Concatenation (Operands : Iir_Array) return Iir; + -- Evaluate a physical literal and return a normalized literal (using -- the primary unit as unit). function Eval_Physical_Literal (Expr : Iir) return Iir; diff --git a/src/vhdl/vhdl-nodes.ads b/src/vhdl/vhdl-nodes.ads index 57c6bb73c..f44f6c4e0 100644 --- a/src/vhdl/vhdl-nodes.ads +++ b/src/vhdl/vhdl-nodes.ads @@ -3540,6 +3540,7 @@ package Vhdl.Nodes is -- Get/Set_Type (Field1) -- -- Get/Set_Operand (Field2) + -- Get/Set_Left (Alias Field2) -- -- Function declaration corresponding to the function to call. -- Get/Set_Implementation (Field3) diff --git a/src/vhdl/vhdl-nodes_meta.adb b/src/vhdl/vhdl-nodes_meta.adb index 48c5129bc..2e3512028 100644 --- a/src/vhdl/vhdl-nodes_meta.adb +++ b/src/vhdl/vhdl-nodes_meta.adb @@ -9692,7 +9692,19 @@ package body Vhdl.Nodes_Meta is function Has_Left (K : Iir_Kind) return Boolean is begin case K is - when Iir_Kind_And_Operator + when Iir_Kind_Identity_Operator + | Iir_Kind_Negation_Operator + | Iir_Kind_Absolute_Operator + | Iir_Kind_Not_Operator + | Iir_Kind_Implicit_Condition_Operator + | Iir_Kind_Condition_Operator + | Iir_Kind_Reduction_And_Operator + | Iir_Kind_Reduction_Or_Operator + | Iir_Kind_Reduction_Nand_Operator + | Iir_Kind_Reduction_Nor_Operator + | Iir_Kind_Reduction_Xor_Operator + | Iir_Kind_Reduction_Xnor_Operator + | Iir_Kind_And_Operator | Iir_Kind_Or_Operator | Iir_Kind_Nand_Operator | Iir_Kind_Nor_Operator diff --git a/src/vhdl/vhdl-sem_expr.adb b/src/vhdl/vhdl-sem_expr.adb index 59159feff..06c689848 100644 --- a/src/vhdl/vhdl-sem_expr.adb +++ b/src/vhdl/vhdl-sem_expr.adb @@ -1703,282 +1703,319 @@ package body Vhdl.Sem_Expr is -- Set when the -fexplicit option was adviced. Explicit_Advice_Given : Boolean := False; - function Sem_Operator (Expr : Iir; Res_Type : Iir; Arity : Positive) - return Iir + -- LEFT and RIGHT must be set. + function Set_Operator_Unique_Interpretation + (Expr : Iir; Decl : Iir) return Iir is - Operator : Name_Id; - Left, Right: Iir; - Interpretation : Name_Interpretation_Type; - Decl : Iir; - Overload_List : Iir_List; - Overload : Iir; - Res_Type_List : Iir; - Full_Compat : Iir; - It : List_Iterator; - - -- LEFT and RIGHT must be set. - function Set_Uniq_Interpretation (Decl : Iir) return Iir - is - Interface_Chain : Iir; - Err : Boolean; - begin - Set_Type (Expr, Get_Return_Type (Decl)); - Interface_Chain := Get_Interface_Declaration_Chain (Decl); - Err := False; - if Is_Overloaded (Left) then - Left := Sem_Expression_Ov - (Left, Get_Base_Type (Get_Type (Interface_Chain))); - if Left = Null_Iir then + Is_Dyadic : constant Boolean := + Get_Kind (Expr) in Iir_Kinds_Dyadic_Operator; + Interface_Chain : Iir; + Err : Boolean; + Left : Iir; + Right : Iir; + begin + Set_Type (Expr, Get_Return_Type (Decl)); + Interface_Chain := Get_Interface_Declaration_Chain (Decl); + Err := False; + Left := Get_Left (Expr); + if Is_Overloaded (Left) then + Left := Sem_Expression_Ov + (Left, Get_Base_Type (Get_Type (Interface_Chain))); + if Left = Null_Iir then + Err := True; + else + Set_Left (Expr, Left); + end if; + end if; + Check_Read (Left); + if Is_Dyadic then + Right := Get_Right (Expr); + if Is_Overloaded (Right) then + Right := Sem_Expression_Ov + (Right, Get_Base_Type (Get_Type (Get_Chain (Interface_Chain)))); + if Right = Null_Iir then Err := True; else - if Arity = 1 then - Set_Operand (Expr, Left); - else - Set_Left (Expr, Left); - end if; - end if; - end if; - Check_Read (Left); - if Arity = 2 then - if Is_Overloaded (Right) then - Right := Sem_Expression_Ov - (Right, - Get_Base_Type (Get_Type (Get_Chain (Interface_Chain)))); - if Right = Null_Iir then - Err := True; - else - Set_Right (Expr, Right); - end if; + Set_Right (Expr, Right); end if; - Check_Read (Right); end if; - Destroy_Iir_List (Overload_List); - if not Err then - Set_Implementation (Expr, Decl); - Sem_Subprogram_Call_Finish (Expr, Decl); - return Eval_Expr_If_Static (Expr); - else - return Expr; - end if; - end Set_Uniq_Interpretation; - - -- Note: operator and implementation node of expr must be set. - procedure Error_Operator_Overload (List : Iir_List) is - begin - Report_Start_Group; - Error_Msg_Sem (+Expr, "operator ""%i"" is overloaded", +Operator); - Disp_Overload_List (List, Expr); - Report_End_Group; - end Error_Operator_Overload; - - Interface_Chain : Iir; - begin - if Arity = 1 then - Left := Get_Operand (Expr); - Right := Null_Iir; + Check_Read (Right); + end if; + if not Err then + Set_Implementation (Expr, Decl); + Sem_Subprogram_Call_Finish (Expr, Decl); + return Eval_Expr_If_Static (Expr); else - Left := Get_Left (Expr); - Right := Get_Right (Expr); + return Expr; end if; - Operator := Utils.Get_Operator_Name (Expr); + end Set_Operator_Unique_Interpretation; - if Get_Type (Expr) = Null_Iir then - -- First pass. - -- Analyze operands. - -- FIXME: should try to analyze right operand even if analyze - -- of left operand has failed ?? - if Get_Type (Left) = Null_Iir then - Left := Sem_Expression_Ov (Left, Null_Iir); - if Left = Null_Iir then - return Null_Iir; - end if; - if Arity = 1 then - Set_Operand (Expr, Left); - else - Set_Left (Expr, Left); - end if; + -- Display an error message for sem_operator. + procedure Error_Operator_Overload (Expr : Iir; List : Iir_List) + is + Operator : Name_Id; + begin + Operator := Utils.Get_Operator_Name (Expr); + Report_Start_Group; + Error_Msg_Sem (+Expr, "operator ""%i"" is overloaded", +Operator); + Disp_Overload_List (List, Expr); + Report_End_Group; + end Error_Operator_Overload; + + -- Return False in case of error. + function Sem_Operator_Operands (Expr : Iir) return Boolean + is + Is_Dyadic : constant Boolean := + Get_Kind (Expr) in Iir_Kinds_Dyadic_Operator; + Left, Right: Iir; + begin + -- First pass. + -- Analyze operands. + -- FIXME: should try to analyze right operand even if analyze + -- of left operand has failed ?? + Left := Get_Left (Expr); + if Get_Type (Left) = Null_Iir then + Left := Sem_Expression_Ov (Left, Null_Iir); + if Left = Null_Iir then + return False; end if; - if Arity = 2 and then Get_Type (Right) = Null_Iir then + Set_Left (Expr, Left); + end if; + if Is_Dyadic then + Right := Get_Right (Expr); + if Get_Type (Right) = Null_Iir then Right := Sem_Expression_Ov (Right, Null_Iir); if Right = Null_Iir then - return Null_Iir; + return False; end if; Set_Right (Expr, Right); end if; + end if; + return True; + end Sem_Operator_Operands; - Overload_List := Create_Iir_List; + function Sem_Operator_Pass1 (Expr : Iir; Res_Type : Iir) return Iir + is + Is_Dyadic : constant Boolean := + Get_Kind (Expr) in Iir_Kinds_Dyadic_Operator; + Operator : constant Name_Id := Utils.Get_Operator_Name (Expr); + Interpretation : Name_Interpretation_Type; + Decl : Iir; + Overload_List : Iir_List; + Res_Type_List : Iir; + It : List_Iterator; - -- Try to find an implementation among user defined function - Interpretation := Get_Interpretation (Operator); - while Valid_Interpretation (Interpretation) loop - Decl := Get_Non_Alias_Declaration (Interpretation); + Interfaces : Iir; + begin + -- First pass. + -- Analyze operands. + -- FIXME: should try to analyze right operand even if analyze + -- of left operand has failed ?? + if not Sem_Operator_Operands (Expr) then + return Null_Iir; + end if; - -- It is compatible with operand types ? - pragma Assert (Is_Function_Declaration (Decl)); + Overload_List := Create_Iir_List; - -- LRM08 12.3 Visibility - -- [...] or all visible declarations denote the same named entity. - -- - -- GHDL: If DECL has already been seen, then skip it. - if Get_Seen_Flag (Decl) then - goto Continue; - end if; + -- Try to find an implementation among user defined function + Interpretation := Get_Interpretation (Operator); + while Valid_Interpretation (Interpretation) loop + Decl := Get_Non_Alias_Declaration (Interpretation); - -- Check return type. - if Res_Type /= Null_Iir - and then (Are_Types_Compatible (Res_Type, Get_Return_Type (Decl)) - = Not_Compatible) - then - goto Continue; - end if; + -- It is compatible with operand types ? + pragma Assert (Is_Function_Declaration (Decl)); - Interface_Chain := Get_Interface_Declaration_Chain (Decl); + -- LRM08 12.3 Visibility + -- [...] or all visible declarations denote the same named entity. + -- + -- GHDL: If DECL has already been seen, then skip it. + if Get_Seen_Flag (Decl) then + goto Continue; + end if; - -- Check arity. + -- Check return type. + if Res_Type /= Null_Iir + and then (Are_Types_Compatible (Res_Type, Get_Return_Type (Decl)) + = Not_Compatible) + then + goto Continue; + end if; - -- LRM93 2.5.2 Operator overloading - -- The subprogram specification of a unary operator must have - -- a single parameter [...] - -- The subprogram specification of a binary operator must have - -- two parameters [...] - -- - -- GHDL: So even in presence of default expression in a parameter, - -- a unary operation has to match with a binary operator. - if Get_Chain_Length (Interface_Chain) /= Arity then - goto Continue; - end if; + Interfaces := Get_Interface_Declaration_Chain (Decl); - -- Check operands. - if Is_Expr_Compatible (Get_Type (Interface_Chain), Left) - = Not_Compatible - then - goto Continue; - end if; - if Arity = 2 then - if Is_Expr_Compatible (Get_Type (Get_Chain (Interface_Chain)), - Right) - = Not_Compatible - then - goto Continue; - end if; - end if; + -- Check arity. - -- Match. - Set_Seen_Flag (Decl, True); - Append_Element (Overload_List, Decl); + -- LRM93 2.5.2 Operator overloading + -- The subprogram specification of a unary operator must have + -- a single parameter [...] + -- The subprogram specification of a binary operator must have + -- two parameters [...] + -- + -- GHDL: So even in presence of default expression in a parameter, + -- a unary operation has to match with a binary operator. + if Get_Chain_Length (Interfaces) /= 1 + Boolean'Pos (Is_Dyadic) then + goto Continue; + end if; - << Continue >> null; - Interpretation := Get_Next_Interpretation (Interpretation); - end loop; + -- Check operands. + if Is_Expr_Compatible (Get_Type (Interfaces), Get_Left (Expr)) + = Not_Compatible + then + goto Continue; + end if; + if Is_Dyadic + and then (Is_Expr_Compatible (Get_Type (Get_Chain (Interfaces)), + Get_Right (Expr)) + = Not_Compatible) + then + goto Continue; + end if; - -- Clear seen_flags. - It := List_Iterate (Overload_List); - while Is_Valid (It) loop - Set_Seen_Flag (Get_Element (It), False); - Next (It); - end loop; + -- Match. + Set_Seen_Flag (Decl, True); + Append_Element (Overload_List, Decl); - -- The list of possible implementations was computed. - case Get_Nbr_Elements (Overload_List) is - when 0 => - if Get_Kind (Expr) = Iir_Kind_Implicit_Condition_Operator then - -- TODO: display expression type. - Error_Msg_Sem (+Expr, "cannot convert expression to boolean " - & "(no ""??"" found)"); - else - Error_Msg_Sem (+Expr, - "no function declarations for %n", +Expr); - end if; - Destroy_Iir_List (Overload_List); - return Null_Iir; + << Continue >> null; + Interpretation := Get_Next_Interpretation (Interpretation); + end loop; - when 1 => - Decl := Get_First_Element (Overload_List); - return Set_Uniq_Interpretation (Decl); + -- Clear seen_flags. + It := List_Iterate (Overload_List); + while Is_Valid (It) loop + Set_Seen_Flag (Get_Element (It), False); + Next (It); + end loop; - when others => - -- Preference for universal operator. - -- This roughly corresponds to: - -- - -- LRM 7.3.5 - -- An implicit conversion of a convertible universal operand - -- is applied if and only if the innermost complete context - -- determines a unique (numeric) target type for the implicit - -- conversion, and there is no legal interpretation of this - -- context without this conversion. - if Arity = 2 then - Decl := Get_Non_Implicit_Subprogram (Overload_List); - if Decl /= Null_Iir then - return Set_Uniq_Interpretation (Decl); - end if; + -- The list of possible implementations was computed. + case Get_Nbr_Elements (Overload_List) is + when 0 => + if Get_Kind (Expr) = Iir_Kind_Implicit_Condition_Operator then + -- TODO: display expression type. + Error_Msg_Sem (+Expr, "cannot convert expression to boolean " + & "(no ""??"" found)"); + else + Error_Msg_Sem (+Expr, + "no function declarations for %n", +Expr); + end if; + Destroy_Iir_List (Overload_List); + return Null_Iir; + + when 1 => + Decl := Get_First_Element (Overload_List); + Destroy_Iir_List (Overload_List); + return Set_Operator_Unique_Interpretation (Expr, Decl); + + when others => + -- Preference for universal operator. + -- This roughly corresponds to: + -- + -- LRM 7.3.5 + -- An implicit conversion of a convertible universal operand + -- is applied if and only if the innermost complete context + -- determines a unique (numeric) target type for the implicit + -- conversion, and there is no legal interpretation of this + -- context without this conversion. + if Is_Dyadic then + Decl := Get_Non_Implicit_Subprogram (Overload_List); + if Decl /= Null_Iir then + Destroy_Iir_List (Overload_List); + return Set_Operator_Unique_Interpretation (Expr, Decl); end if; + end if; - Set_Implementation (Expr, Create_Overload_List (Overload_List)); - - -- Create the list of possible return types, if it is not yet - -- determined. - if Res_Type = Null_Iir then - Res_Type_List := Create_List_Of_Types (Overload_List); - if Is_Overload_List (Res_Type_List) then - -- There are many possible return types. - -- Try again. - Set_Type (Expr, Res_Type_List); - return Expr; - end if; + Set_Implementation (Expr, Create_Overload_List (Overload_List)); + + -- Create the list of possible return types, if it is not yet + -- determined. + if Res_Type = Null_Iir then + Res_Type_List := Create_List_Of_Types (Overload_List); + if Is_Overload_List (Res_Type_List) then + -- There are many possible return types. + -- Try again. + Set_Type (Expr, Res_Type_List); + return Expr; end if; + end if; - -- The return type is known. - -- Search for explicit subprogram. + -- The return type is known. + -- Search for explicit subprogram. - -- It was impossible to find one solution. - Error_Operator_Overload (Overload_List); + -- It was impossible to find one solution. + Error_Operator_Overload (Expr, Overload_List); - -- Give an advice. - if not Flags.Flag_Explicit - and then not Explicit_Advice_Given - and then Flags.Vhdl_Std < Vhdl_08 - then - Decl := Get_Explicit_Subprogram (Overload_List); - if Decl /= Null_Iir then - Error_Msg_Sem - (+Expr, "(you may want to use the -fexplicit option)"); - Explicit_Advice_Given := True; - end if; + -- Give an advice. + if not Flags.Flag_Explicit + and then not Explicit_Advice_Given + and then Flags.Vhdl_Std < Vhdl_08 + then + Decl := Get_Explicit_Subprogram (Overload_List); + if Decl /= Null_Iir then + Error_Msg_Sem + (+Expr, "(you may want to use the -fexplicit option)"); + Explicit_Advice_Given := True; end if; + end if; + + return Null_Iir; + end case; + end Sem_Operator_Pass1; + function Sem_Operator_Pass2_Interpretation + (Expr : Iir; Res_Type : Iir) return Iir + is + Decl : Iir; + Overload : Iir; + Overload_List : Iir_List; + Full_Compat : Iir; + It : List_Iterator; + begin + -- Second pass + -- Find the uniq implementation for this call. + Overload := Get_Implementation (Expr); + Overload_List := Get_Overload_List (Overload); + Full_Compat := Null_Iir; + It := List_Iterate (Overload_List); + while Is_Valid (It) loop + Decl := Get_Element (It); + -- FIXME: wrong: compatibilty with return type and args. + if Are_Types_Compatible (Get_Return_Type (Decl), Res_Type) + /= Not_Compatible + then + if Full_Compat /= Null_Iir then + Error_Operator_Overload (Expr, Overload_List); return Null_Iir; - end case; - else - -- Second pass - -- Find the uniq implementation for this call. - Overload := Get_Implementation (Expr); - Overload_List := Get_Overload_List (Overload); - Full_Compat := Null_Iir; - It := List_Iterate (Overload_List); - while Is_Valid (It) loop - Decl := Get_Element (It); - -- FIXME: wrong: compatibilty with return type and args. - if Are_Types_Compatible (Get_Return_Type (Decl), Res_Type) - /= Not_Compatible - then - if Full_Compat /= Null_Iir then - Error_Operator_Overload (Overload_List); - return Null_Iir; - else - Full_Compat := Decl; - end if; + else + Full_Compat := Decl; end if; - Next (It); - end loop; - Free_Iir (Overload); - Overload := Get_Type (Expr); - Free_Overload_List (Overload); - if Full_Compat = Null_Iir then - Error_Msg_Sem (+Expr, - "no matching function declarations for %n", +Expr); + end if; + Next (It); + end loop; + Free_Iir (Overload); + Overload := Get_Type (Expr); + Free_Overload_List (Overload); + Destroy_Iir_List (Overload_List); + if Full_Compat = Null_Iir then + Error_Msg_Sem (+Expr, + "no matching function declarations for %n", +Expr); + return Null_Iir; + else + Destroy_Iir_List (Overload_List); + return Full_Compat; + end if; + end Sem_Operator_Pass2_Interpretation; + + function Sem_Operator (Expr : Iir; Res_Type : Iir) return Iir + is + Interpretation : Iir; + begin + if Get_Type (Expr) = Null_Iir then + return Sem_Operator_Pass1 (Expr, Res_Type); + else + Interpretation := Sem_Operator_Pass2_Interpretation (Expr, Res_Type); + if Interpretation = Null_Iir then return Null_Iir; else - return Set_Uniq_Interpretation (Full_Compat); + return Set_Operator_Unique_Interpretation (Expr, Interpretation); end if; end if; end Sem_Operator; @@ -4372,6 +4409,138 @@ package body Vhdl.Sem_Expr is end if; end Check_Constant_Restriction; + function Sem_Dyadic_Operator (Expr : Iir; Atype : Iir) return Iir + is + Arr : Iir_Array (1 .. 128); + Len : Natural; + begin + -- Try to linearize the tree in order to reduce recursion depth + -- and also improve speed of evaluation. + -- This is particularly useful for repeated concatenations. + declare + Left : Iir; + begin + Len := 0; + Left := Expr; + while Len < Arr'Last + and then Get_Kind (Left) in Iir_Kinds_Dyadic_Operator + loop + Len := Len + 1; + Arr (Len) := Left; + Left := Get_Left (Left); + end loop; + end; + + -- No possibility to linearize... + if Len = 1 then + return Sem_Operator (Expr, Atype); + end if; + + if Get_Type (Expr) = Null_Iir then + -- First pass. + Arr (Len) := Sem_Operator_Pass1 (Arr (Len), Null_Iir); + if Arr (Len) = Null_Iir then + return Null_Iir; + end if; + for I in reverse 2 .. Len - 1 loop + Set_Left (Arr (I), Arr (I + 1)); + Arr (I) := Sem_Operator_Pass1 (Arr (I), Null_Iir); + if Arr (I) = Null_Iir then + return Null_Iir; + end if; + end loop; + Set_Left (Arr (1), Arr (2)); + Arr (1) := Sem_Operator_Pass1 (Arr (1), Atype); + return Arr (1); + else + -- Second pass. + declare + Op_Type : Iir; + Decl : Iir; + Interfaces : Iir; + Left, Right : Iir; + Is_All_Concat : Boolean; + Imp : Iir; + Err : Boolean; + begin + Op_Type := Atype; + Err := False; + for I in 1 .. Len loop + if not Is_Overloaded (Arr (I)) then + pragma Assert (I > 1); + exit; + end if; + Decl := Sem_Operator_Pass2_Interpretation + (Arr (I), Op_Type); + if Decl = Null_Iir then + -- Stop in case of error. + return Null_Iir; + end if; + Set_Type (Arr (I), Get_Return_Type (Decl)); + Set_Implementation (Arr (I), Decl); + Interfaces := Get_Interface_Declaration_Chain (Decl); + Op_Type := Get_Base_Type (Get_Type (Interfaces)); + + -- Right operand. + Right := Get_Right (Arr (I)); + if Is_Overloaded (Right) then + Right := Get_Right (Arr (I)); + Right := Sem_Expression_Ov + (Right, + Get_Base_Type (Get_Type (Get_Chain (Interfaces)))); + if Right = Null_Iir then + Err := True; + else + Set_Right (Arr (I), Right); + end if; + end if; + Check_Read (Right); + end loop; + + Left := Get_Left (Arr (Len)); + if Is_Overloaded (Left) then + Left := Sem_Expression_Ov + (Left, Get_Base_Type (Get_Type (Interfaces))); + if Left = Null_Iir then + Err := True; + else + Set_Left (Arr (Len), Left); + end if; + end if; + + -- Finish + + if not Err then + Is_All_Concat := True; + for I in reverse 1 .. Len loop + Imp := Get_Implementation (Arr (I)); + Sem_Subprogram_Call_Finish (Arr (I), Imp); + Is_All_Concat := Is_All_Concat + and then (Get_Implicit_Definition (Imp) + in Iir_Predefined_Concat_Functions); + end loop; + if Get_Expr_Staticness (Arr (1)) = Locally then + if Is_All_Concat + then + Arr (1) := Eval_Concatenation (Arr (1 .. Len)); + else + Arr (1) := Eval_Expr_If_Static (Arr (1)); + end if; + else + for I in reverse 1 .. Len loop + exit when Get_Expr_Staticness (Arr (I)) /= Locally; + Arr (I) := Eval_Expr_If_Static (Arr (I)); + if I > 1 then + Set_Left (Arr (I - 1), Arr (I)); + end if; + end loop; + end if; + end if; + return Arr (1); + end; + end if; + end Sem_Dyadic_Operator; + -- Set semantic to EXPR. -- Replace simple_name with the referenced node, -- Set type to nodes, @@ -4438,10 +4607,10 @@ package body Vhdl.Sem_Expr is return Expr; when Iir_Kinds_Monadic_Operator => - return Sem_Operator (Expr, A_Type, 1); + return Sem_Operator (Expr, A_Type); when Iir_Kinds_Dyadic_Operator => - return Sem_Operator (Expr, A_Type, 2); + return Sem_Dyadic_Operator (Expr, A_Type); when Iir_Kind_Enumeration_Literal | Iir_Kinds_Object_Declaration => @@ -5185,7 +5354,7 @@ package body Vhdl.Sem_Expr is Location_Copy (Op, Cond); Set_Operand (Op, Cond); - Res := Sem_Operator (Op, Boolean_Type_Definition, 1); + Res := Sem_Operator (Op, Boolean_Type_Definition); Check_Read (Res); return Res; end Insert_Condition_Operator; -- cgit v1.2.3