From 03b3ac7d9821ecf4baad4142a3317325efea7df5 Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Sat, 27 Jun 2015 09:35:30 +0200 Subject: Improve code generation of strings. --- src/vhdl/evaluation.adb | 75 ++++++++++++++++++-- src/vhdl/evaluation.ads | 3 + src/vhdl/sem_expr.adb | 139 ++++++++++++++++++++----------------- src/vhdl/sem_stmts.adb | 1 + src/vhdl/translate/trans-chap7.adb | 123 ++++++++++++++++++-------------- 5 files changed, 218 insertions(+), 123 deletions(-) diff --git a/src/vhdl/evaluation.adb b/src/vhdl/evaluation.adb index 589ab1fb2..c2283c57c 100644 --- a/src/vhdl/evaluation.adb +++ b/src/vhdl/evaluation.adb @@ -1866,9 +1866,7 @@ package body Evaluation is Res := Build_Constant (Val, Conv); if Get_Constraint_State (Conv_Type) = Fully_Constrained then Set_Type (Res, Conv_Type); - if Eval_Discrete_Type_Length (Conv_Index_Type) - /= Eval_Discrete_Type_Length (Val_Index_Type) - then + if not Eval_Is_In_Bound (Val, Conv_Type) then Warning_Msg_Sem ("non matching length in type conversion", Conv); return Build_Overflow (Conv); @@ -2471,7 +2469,7 @@ package body Evaluation is return True; end Eval_Fp_In_Range; - -- Return TRUE if literal EXPR is in SUB_TYPE bounds. + -- Return FALSE if literal EXPR is not in SUB_TYPE bounds. function Eval_Is_In_Bound (Expr : Iir; Sub_Type : Iir) return Boolean is Type_Range : Iir; @@ -2494,28 +2492,91 @@ package body Evaluation is case Get_Kind (Sub_Type) is when Iir_Kind_Integer_Subtype_Definition => + if Get_Expr_Staticness (Expr) /= Locally + or else Get_Type_Staticness (Sub_Type) /= Locally + then + return True; + end if; Type_Range := Get_Range_Constraint (Sub_Type); return Eval_Int_In_Range (Get_Value (Val), Type_Range); when Iir_Kind_Floating_Subtype_Definition => + if Get_Expr_Staticness (Expr) /= Locally + or else Get_Type_Staticness (Sub_Type) /= Locally + then + return True; + end if; Type_Range := Get_Range_Constraint (Sub_Type); return Eval_Fp_In_Range (Get_Fp_Value (Val), Type_Range); when Iir_Kind_Enumeration_Subtype_Definition | Iir_Kind_Enumeration_Type_Definition => + if Get_Expr_Staticness (Expr) /= Locally + or else Get_Type_Staticness (Sub_Type) /= Locally + then + return True; + end if; -- A check is required for an enumeration type definition for -- 'val attribute. Type_Range := Get_Range_Constraint (Sub_Type); return Eval_Int_In_Range (Iir_Int64 (Get_Enum_Pos (Val)), Type_Range); when Iir_Kind_Physical_Subtype_Definition => + if Get_Expr_Staticness (Expr) /= Locally + or else Get_Type_Staticness (Sub_Type) /= Locally + then + return True; + end if; Type_Range := Get_Range_Constraint (Sub_Type); return Eval_Phys_In_Range (Get_Physical_Value (Val), Type_Range); when Iir_Kind_Base_Attribute => + if Get_Expr_Staticness (Expr) /= Locally + or else Get_Type_Staticness (Sub_Type) /= Locally + then + return True; + end if; return Eval_Is_In_Bound (Val, Get_Type (Sub_Type)); - when Iir_Kind_Array_Subtype_Definition - | Iir_Kind_Array_Type_Definition - | Iir_Kind_Record_Type_Definition => + when Iir_Kind_Array_Subtype_Definition => + declare + Val_Type : constant Iir := Get_Type (Val); + begin + if Get_Constraint_State (Sub_Type) /= Fully_Constrained + or else + Get_Kind (Val_Type) /= Iir_Kind_Array_Subtype_Definition + or else + Get_Constraint_State (Val_Type) /= Fully_Constrained + then + -- Cannot say no. + return True; + end if; + declare + E_Indexes : constant Iir_List := + Get_Index_Subtype_List (Val_Type); + T_Indexes : constant Iir_List := + Get_Index_Subtype_List (Sub_Type); + E_El : Iir; + T_El : Iir; + begin + for I in Natural loop + E_El := Get_Index_Type (E_Indexes, I); + T_El := Get_Index_Type (T_Indexes, I); + exit when E_El = Null_Iir and T_El = Null_Iir; + + if Get_Type_Staticness (E_El) = Locally + and then Get_Type_Staticness (T_El) = Locally + and then (Eval_Discrete_Type_Length (E_El) + /= Eval_Discrete_Type_Length (T_El)) + then + return False; + end if; + end loop; + return True; + end; + end; + + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => -- FIXME: do it. return True; diff --git a/src/vhdl/evaluation.ads b/src/vhdl/evaluation.ads index be2f92e05..440570796 100644 --- a/src/vhdl/evaluation.ads +++ b/src/vhdl/evaluation.ads @@ -127,6 +127,9 @@ package Evaluation is -- IS_POS is true) or extreme negative value. function Build_Extreme_Value (Is_Pos : Boolean; Origin : Iir) return Iir; + -- Create a Iir_Kind_Overflow node of type EXPR_TYPE for ORIGIN. + function Build_Overflow (Origin : Iir; Expr_Type : Iir) return Iir; + -- Create an array subtype from LEN and BASE_TYPE, according to rules -- of LRM93 7.3.2.2. (which are the same as LRM93 7.2.4). function Create_Unidim_Array_By_Length diff --git a/src/vhdl/sem_expr.adb b/src/vhdl/sem_expr.adb index bef2c739d..1cab4d190 100644 --- a/src/vhdl/sem_expr.adb +++ b/src/vhdl/sem_expr.adb @@ -547,10 +547,10 @@ package body Sem_Expr is end if; end Search_Compatible_Type; - -- Semantize the range expression EXPR. + -- Analyze the range expression EXPR. -- If A_TYPE is not null_iir, EXPR is expected to be of type A_TYPE. -- LRM93 3.2.1.1 - -- FIXME: avoid to run it on an already semantized node, be careful + -- FIXME: avoid to run it on an already analyzed node, be careful -- with range_type_expr. function Sem_Simple_Range_Expression (Expr: Iir_Range_Expression; A_Type: Iir; Any_Dir : Boolean) @@ -703,7 +703,7 @@ package body Sem_Expr is -- a range attribute -- a range type definition -- LRM93 3.2.1.1 - -- FIXME: avoid to run it on an already semantized node, be careful + -- FIXME: avoid to run it on an already analyzed node, be careful -- with range_type_expr. function Sem_Range_Expression (Expr: Iir; A_Type: Iir; Any_Dir : Boolean) return Iir @@ -1360,7 +1360,7 @@ package body Sem_Expr is end Sem_Subprogram_Call_Stage1; -- For a procedure call, A_TYPE must be null. - -- Associations must have already been semantized by sem_association_list. + -- Associations must have already been analyzed by sem_association_list. function Sem_Subprogram_Call (Expr: Iir; A_Type: Iir) return Iir is Is_Func: constant Boolean := Get_Kind (Expr) = Iir_Kind_Function_Call; @@ -1755,8 +1755,8 @@ package body Sem_Expr is if Get_Type (Expr) = Null_Iir then -- First pass. - -- Semantize operands. - -- FIXME: should try to semantize right operand even if semantization + -- 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); @@ -1943,7 +1943,7 @@ package body Sem_Expr is end if; end Sem_Operator; - -- Semantize LIT whose elements must be of type EL_TYPE, and return + -- Analyze LIT whose elements must be of type EL_TYPE, and return -- the length. -- FIXME: the errors are reported, but there is no mark of that. function Sem_String_Literal (Str : Iir; El_Type : Iir) return Natural @@ -2377,7 +2377,7 @@ package body Sem_Expr is return True; end Replace_By_Range_Choice; - -- Semantize a simple (by expression or by range) choice. + -- Analyze a simple (by expression or by range) choice. -- Return FALSE in case of error. function Sem_Simple_Choice return Boolean is @@ -2515,7 +2515,7 @@ package body Sem_Expr is High := Null_Iir; -- First: - -- semantize the choices + -- Analyze the choices -- compute the range of positionnal choices -- compute the number of choice elements (extracted from lists). -- check for others presence. @@ -2901,7 +2901,7 @@ package body Sem_Expr is end if; end Add_Match; - -- Semantize a simple choice: extract the record element corresponding + -- Analyze a simple choice: extract the record element corresponding -- to the expression, and create a choice_by_name. -- FIXME: should mutate the node. function Sem_Simple_Choice (Ass : Iir) return Iir @@ -3012,7 +3012,7 @@ package body Sem_Expr is Error_Kind ("sem_record_aggregate", El); end case; - -- Semantize the expression associated. + -- Analyze the expression associated. if Expr /= Null_Iir then if El_Type /= Null_Iir then Expr := Sem_Expression (Expr, El_Type); @@ -3075,11 +3075,14 @@ package body Sem_Expr is -- True if there is an error. Error : Boolean := False; + + -- True if one element doesn't match the bounds. + Has_Bound_Error : Boolean := False; end record; type Array_Aggr_Info_Arr is array (Natural range <>) of Array_Aggr_Info; - -- Semantize an array aggregate AGGR of *base type* A_TYPE. + -- Analyze an array aggregate AGGR of *base type* A_TYPE. -- The type of the array is computed into A_SUBTYPE. -- DIM is the dimension index in A_TYPE. -- Return FALSE in case of error. @@ -3089,29 +3092,26 @@ package body Sem_Expr is Constrained : Boolean; Dim: Natural) is + Index_List : constant Iir_List := Get_Index_Subtype_List (A_Type); + + -- Type of the index (this is also the type of the choices). + Index_Type : constant Iir := Get_Index_Type (Index_List, Dim - 1); + Assoc_Chain : Iir; Choice: Iir; Is_Positional: Tri_State_Type; Has_Positional_Choice: Boolean; Low, High : Iir; - Index_List : Iir_List; Has_Others : Boolean; Len : Natural; - -- Type of the index (this is also the type of the choices). - Index_Type : Iir; - - --Index_Subtype : Iir; Index_Subtype_Constraint : Iir_Range_Expression; Index_Constraint : Iir_Range_Expression; -- FIXME: 'range. Choice_Staticness : Iir_Staticness; Info : Array_Aggr_Info renames Infos (Dim); begin - Index_List := Get_Index_Subtype_List (A_Type); - Index_Type := Get_Index_Type (Index_List, Dim - 1); - -- Sem choices. case Get_Kind (Aggr) is when Iir_Kind_Aggregate => @@ -3359,51 +3359,59 @@ package body Sem_Expr is end if; end if; - -- Semantize aggregate elements. + -- Analyze aggregate elements. if Dim = Get_Nbr_Elements (Index_List) then - -- A type has been found for AGGR, semantize AGGR as if it was - -- an aggregate with a subtype. + -- A type has been found for AGGR, analyze AGGR as if it was + -- an aggregate with a subtype (and not a string). - if Get_Kind (Aggr) = Iir_Kind_Aggregate then - -- LRM93 7.3.2.2: - -- the expression of each element association must be of the - -- element type. - declare - El : Iir; - Element_Type : Iir; - Expr : Iir; - Value_Staticness : Iir_Staticness; - Expr_Staticness : Iir_Staticness; - begin - Element_Type := Get_Element_Subtype (A_Type); - El := Assoc_Chain; - Value_Staticness := Locally; - while El /= Null_Iir loop - Expr := Get_Associated_Expr (El); + if Get_Kind (Aggr) /= Iir_Kind_Aggregate then + return; + end if; + + -- LRM93 7.3.2.2: + -- the expression of each element association must be of the + -- element type. + declare + Element_Type : constant Iir := Get_Element_Subtype (A_Type); + El : Iir; + Expr : Iir; + Value_Staticness : Iir_Staticness; + Expr_Staticness : Iir_Staticness; + begin + El := Assoc_Chain; + Value_Staticness := Locally; + while El /= Null_Iir loop + Expr := Get_Associated_Expr (El); + if Expr /= Null_Iir then + Expr := Sem_Expression (Expr, Element_Type); if Expr /= Null_Iir then - Expr := Sem_Expression (Expr, Element_Type); - if Expr /= Null_Iir then - Expr_Staticness := Get_Expr_Staticness (Expr); - Set_Expr_Staticness - (Aggr, Min (Get_Expr_Staticness (Aggr), - Expr_Staticness)); - Set_Associated_Expr (El, Eval_Expr_If_Static (Expr)); - - -- FIXME: handle name/others in translate. - -- if Get_Kind (Expr) = Iir_Kind_Aggregate then - -- Expr_Staticness := Get_Value_Staticness (Expr); - -- end if; - Value_Staticness := Min (Value_Staticness, - Expr_Staticness); - else - Info.Error := True; + Expr_Staticness := Get_Expr_Staticness (Expr); + Set_Expr_Staticness (Aggr, + Min (Get_Expr_Staticness (Aggr), + Expr_Staticness)); + Expr := Eval_Expr_If_Static (Expr); + Set_Associated_Expr (El, Expr); + + if not Eval_Is_In_Bound (Expr, Element_Type) + then + Info.Has_Bound_Error := True; + Warning_Msg_Sem ("element is out of the bounds", Expr); end if; + + -- FIXME: handle name/others in translate. + -- if Get_Kind (Expr) = Iir_Kind_Aggregate then + -- Expr_Staticness := Get_Value_Staticness (Expr); + -- end if; + Value_Staticness := Min (Value_Staticness, + Expr_Staticness); + else + Info.Error := True; end if; - El := Get_Chain (El); - end loop; - Set_Value_Staticness (Aggr, Value_Staticness); - end; - end if; + end if; + El := Get_Chain (El); + end loop; + Set_Value_Staticness (Aggr, Value_Staticness); + end; else declare Assoc : Iir; @@ -3442,15 +3450,14 @@ package body Sem_Expr is end if; end Sem_Array_Aggregate_Type_1; - -- Semantize an array aggregate whose type is AGGR_TYPE. + -- Analyze an array aggregate whose type is AGGR_TYPE. -- If CONSTRAINED is true, then the aggregate appears in one of the -- context and can have an 'others' choice. -- If CONSTRAINED is false, the aggregate can not have an 'others' choice. -- Create a subtype for this aggregate. -- Return NULL_IIR in case of error, or AGGR if not. function Sem_Array_Aggregate_Type - (Aggr : Iir; Aggr_Type : Iir; Constrained : Boolean) - return Iir + (Aggr : Iir; Aggr_Type : Iir; Constrained : Boolean) return Iir is A_Subtype: Iir; Base_Type : Iir; @@ -3460,7 +3467,7 @@ package body Sem_Expr is Aggr_Constrained : Boolean; Info, Prev_Info : Iir_Aggregate_Info; begin - -- Semantize the aggregate. + -- Analyze the aggregate. Sem_Array_Aggregate_Type_1 (Aggr, Aggr_Type, Infos, Constrained, 1); Aggr_Constrained := True; @@ -3505,6 +3512,10 @@ package body Sem_Expr is end loop; end if; + if Infos (Nbr_Dim).Has_Bound_Error then + return Build_Overflow (Aggr, Get_Type (Aggr)); + end if; + Prev_Info := Null_Iir; for I in Infos'Range loop -- Create info and link. diff --git a/src/vhdl/sem_stmts.adb b/src/vhdl/sem_stmts.adb index 593ded84c..714336212 100644 --- a/src/vhdl/sem_stmts.adb +++ b/src/vhdl/sem_stmts.adb @@ -716,6 +716,7 @@ package body Sem_Stmts is if not Check_Implicit_Conversion (Get_Type (Target), Expr) then Warning_Msg_Sem ("expression length does not match target length", Stmt); + Set_Expression (Stmt, Build_Overflow (Expr, Get_Type (Target))); end if; end Sem_Variable_Assignment; diff --git a/src/vhdl/translate/trans-chap7.adb b/src/vhdl/translate/trans-chap7.adb index 4833564bd..c11f930c7 100644 --- a/src/vhdl/translate/trans-chap7.adb +++ b/src/vhdl/translate/trans-chap7.adb @@ -40,6 +40,68 @@ package body Trans.Chap7 is use Trans.Helpers; procedure Copy_Range (Dest : Mnode; Src : Mnode); + function Translate_Static_Implicit_Conv + (Expr : O_Cnode; Expr_Type : Iir; Res_Type : Iir) + return O_Cnode + is + Expr_Info : Type_Info_Acc; + Res_Info : Type_Info_Acc; + Val : Var_Type; + Res : O_Cnode; + List : O_Record_Aggr_List; + Bound : Var_Type; + begin + if Res_Type = Expr_Type then + return Expr; + end if; + + -- EXPR must be already constrained. + pragma Assert (Get_Kind (Expr_Type) = Iir_Kind_Array_Subtype_Definition); + if Get_Kind (Res_Type) = Iir_Kind_Array_Subtype_Definition + and then Get_Constraint_State (Res_Type) = Fully_Constrained + then + -- constrained to constrained. + if not Chap3.Locally_Array_Match (Expr_Type, Res_Type) then + -- Sem should have replaced the expression by an overflow. + raise Internal_Error; + -- Chap6.Gen_Bound_Error (Loc); + end if; + + -- Constrained to constrained should be OK, as already checked by + -- sem. + return Expr; + end if; + + -- Handle only constrained to unconstrained conversion. + pragma Assert (Get_Kind (Res_Type) in Iir_Kinds_Array_Type_Definition); + pragma Assert (Get_Constraint_State (Res_Type) = Unconstrained); + + Expr_Info := Get_Info (Expr_Type); + Res_Info := Get_Info (Res_Type); + Val := Create_Global_Const + (Create_Uniq_Identifier, Expr_Info.Ortho_Type (Mode_Value), + O_Storage_Private, Expr); + Bound := Expr_Info.T.Array_Bounds; + if Bound = Null_Var then + Bound := Create_Global_Const + (Create_Uniq_Identifier, Expr_Info.T.Bounds_Type, + O_Storage_Private, + Chap3.Create_Static_Array_Subtype_Bounds (Expr_Type)); + Expr_Info.T.Array_Bounds := Bound; + end if; + + Start_Record_Aggr (List, Res_Info.Ortho_Type (Mode_Value)); + New_Record_Aggr_El + (List, New_Global_Address (Get_Var_Label (Val), + Res_Info.T.Base_Ptr_Type (Mode_Value))); + New_Record_Aggr_El + (List, New_Global_Address (Get_Var_Label (Bound), + Expr_Info.T.Bounds_Ptr_Type)); + Finish_Record_Aggr (List, Res); + + return Res; + end Translate_Static_Implicit_Conv; + function Is_Static_Constant (Decl : Iir_Constant_Declaration) return Boolean is Expr : constant Iir := Get_Default_Value (Decl); @@ -368,7 +430,7 @@ package body Trans.Chap7 is return Res; end Translate_Static_String; - function Translate_String_Literal (Str : Iir) return O_Enode + function Translate_String_Literal (Str : Iir; Res_Type : Iir) return O_Enode is Str_Type : constant Iir := Get_Type (Str); Var : Var_Type; @@ -391,64 +453,20 @@ package body Trans.Chap7 is when others => raise Internal_Error; end case; - Info := Get_Info (Str_Type); + Res := Translate_Static_Implicit_Conv (Res, Str_Type, Res_Type); + Info := Get_Info (Res_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)); return R; else - return Translate_Non_Static_String_Literal (Str); + return Translate_Implicit_Conv + (Translate_Non_Static_String_Literal (Str), Str_Type, Res_Type, + Mode_Value, Str); end if; end Translate_String_Literal; - function Translate_Static_Implicit_Conv - (Expr : O_Cnode; Expr_Type : Iir; Res_Type : Iir) return O_Cnode - is - Expr_Info : Type_Info_Acc; - Res_Info : Type_Info_Acc; - Val : Var_Type; - Res : O_Cnode; - List : O_Record_Aggr_List; - Bound : Var_Type; - begin - if Res_Type = Expr_Type then - return Expr; - end if; - if Get_Kind (Expr_Type) /= Iir_Kind_Array_Subtype_Definition then - raise Internal_Error; - end if; - if Get_Kind (Res_Type) = Iir_Kind_Array_Subtype_Definition then - return Expr; - end if; - if Get_Kind (Res_Type) /= Iir_Kind_Array_Type_Definition then - raise Internal_Error; - end if; - Expr_Info := Get_Info (Expr_Type); - Res_Info := Get_Info (Res_Type); - Val := Create_Global_Const - (Create_Uniq_Identifier, Expr_Info.Ortho_Type (Mode_Value), - O_Storage_Private, Expr); - Bound := Expr_Info.T.Array_Bounds; - if Bound = Null_Var then - Bound := Create_Global_Const - (Create_Uniq_Identifier, Expr_Info.T.Bounds_Type, - O_Storage_Private, - Chap3.Create_Static_Array_Subtype_Bounds (Expr_Type)); - Expr_Info.T.Array_Bounds := Bound; - end if; - - Start_Record_Aggr (List, Res_Info.Ortho_Type (Mode_Value)); - New_Record_Aggr_El - (List, New_Global_Address (Get_Var_Label (Val), - Res_Info.T.Base_Ptr_Type (Mode_Value))); - New_Record_Aggr_El - (List, New_Global_Address (Get_Var_Label (Bound), - Expr_Info.T.Bounds_Ptr_Type)); - Finish_Record_Aggr (List, Res); - return Res; - end Translate_Static_Implicit_Conv; - function Translate_Numeric_Literal (Expr : Iir; Res_Type : O_Tnode) return O_Cnode is begin @@ -527,7 +545,8 @@ package body Trans.Chap7 is when Iir_Kind_String_Literal8 => return Translate_Static_Implicit_Conv - (Translate_Static_String_Literal8 (Expr), Expr_Type, Res_Type); + (Translate_Static_String_Literal8 (Expr), + Expr_Type, Res_Type); when Iir_Kind_Simple_Aggregate => return Translate_Static_Implicit_Conv (Translate_Static_Simple_Aggregate (Expr), @@ -3699,7 +3718,7 @@ package body Trans.Chap7 is when Iir_Kind_String_Literal8 | Iir_Kind_Simple_Aggregate | Iir_Kind_Simple_Name_Attribute => - Res := Translate_String_Literal (Expr); + return Translate_String_Literal (Expr, Res_Type); when Iir_Kind_Aggregate => declare -- cgit v1.2.3