diff options
Diffstat (limited to 'translate/translation.adb')
| -rw-r--r-- | translate/translation.adb | 336 |
1 files changed, 215 insertions, 121 deletions
diff --git a/translate/translation.adb b/translate/translation.adb index 7881530c5..a55314a4a 100644 --- a/translate/translation.adb +++ b/translate/translation.adb @@ -1377,8 +1377,15 @@ package body Translation is function Get_Resolv_Ortho_Decl (Func : Iir) return O_Dnode is + Info : Subprg_Resolv_Info_Acc; begin - return Get_Info (Func).Subprg_Resolv.Resolv_Func; + Info := Get_Info (Func).Subprg_Resolv; + if Info = null then + -- Maybe the resolver is not used. + return O_Dnode_Null; + else + return Info.Resolv_Func; + end if; end Get_Resolv_Ortho_Decl; -- Return true is INFO is a type info for a composite type, ie: @@ -1987,8 +1994,10 @@ package body Translation is -- Get the offset in the range pointed by RANGE_PTR of INDEX. -- This checks INDEX belongs to the range. + -- INDEX_TYPE is the subtype of the array index. function Translate_Index_To_Offset (Range_Ptr : O_Dnode; Index : O_Enode; + Index_Expr : Iir; Index_Type : Iir; Loc : Iir) return O_Enode; @@ -2249,6 +2258,9 @@ package body Translation is -- Close the temporary region. procedure Close_Temp; + -- Check there is no temporary region. + procedure Check_No_Temp; + -- Free all old temp. -- Used only to free memory. procedure Free_Old_Temp; @@ -3099,6 +3111,9 @@ package body Translation is -- never deallocated. Old_Level : Temp_Level_Acc := null; + -- If set, emit comments for open_temp/close_temp. + Flag_Debug_Temp : constant Boolean := False; + procedure Open_Temp is L : Temp_Level_Acc; @@ -3119,6 +3134,10 @@ package body Translation is L.Level := Temp_Level.Level + 1; end if; Temp_Level := L; + if Flag_Debug_Temp then + New_Debug_Comment_Stmt + ("Open_Temp level " & Natural'Image (L.Level)); + end if; end Open_Temp; procedure Add_Transient_Type_In_Temp (Atype : Iir) @@ -3139,6 +3158,11 @@ package body Translation is -- OPEN_TEMP was not called. raise Internal_Error; end if; + if Flag_Debug_Temp then + New_Debug_Comment_Stmt + ("Close_Temp level " & Natural'Image (Temp_Level.Level)); + end if; + if Temp_Level.Stack2_Mark /= O_Dnode_Null then Start_Association (Constr, Ghdl_Stack2_Release); New_Association (Constr, @@ -3171,6 +3195,13 @@ package body Translation is Old_Level := L; end Close_Temp; + procedure Check_No_Temp is + begin + if Temp_Level /= null then + raise Internal_Error; + end if; + end Check_No_Temp; + procedure Free_Old_Temp is procedure Free is new Ada.Unchecked_Deallocation @@ -4258,8 +4289,7 @@ package body Translation is Chap7.Translate_Expression (Get_Nth_Element (Get_Index_List (Spec), 0), Iter_Type), - Iter_Type, - Spec), + Scheme, Iter_Type, Spec), True); Close_Temp; end; @@ -4289,8 +4319,7 @@ package body Translation is (Range_Ptr, New_Value (New_Selected_Element (New_Obj (Slice), Type_Info.T.Range_Left)), - Iter_Type, - Spec)); + Spec, Iter_Type, Spec)); Right := Create_Temp_Init (Ghdl_Index_Type, Chap6.Translate_Index_To_Offset @@ -4298,8 +4327,7 @@ package body Translation is New_Value (New_Selected_Element (New_Obj (Slice), Type_Info.T.Range_Right)), - Iter_Type, - Spec)); + Spec, Iter_Type, Spec)); Index := Create_Temp (Ghdl_Index_Type); High := Create_Temp (Ghdl_Index_Type); Start_If_Stmt @@ -4786,6 +4814,8 @@ package body Translation is Chap4.Elab_Declaration_Chain (Subprg, Final); + pragma Debug (Check_No_Temp); + -- If finalization is required, create a dummy loop around the -- body and convert returns into exit out of this loop. -- If the subprogram is a function, also create a variable for the @@ -4838,6 +4868,8 @@ package body Translation is Finish_Subprogram_Body; + pragma Debug (Check_No_Temp); + Pop_Identifier_Prefix (Mark); end Translate_Subprogram_Body; @@ -5318,7 +5350,7 @@ package body Translation is Info.C := new Complex_Type_Info; Info.C.Size_Var (Mode_Value) := Create_Var (Create_Var_Identifier ("SIZE"), Ghdl_Index_Type); - if Get_Signal_Type_Flag (Def) then + if Get_Has_Signal_Flag (Def) then Info.C.Size_Var (Mode_Signal) := Create_Var (Create_Var_Identifier ("SIGSIZE"), Ghdl_Index_Type); end if; @@ -5790,7 +5822,7 @@ package body Translation is ------------- function Type_To_Last_Object_Kind (Def : Iir) return Object_Kind_Type is begin - if Get_Signal_Type_Flag (Def) then + if Get_Has_Signal_Flag (Def) then return Mode_Signal; else return Mode_Value; @@ -6015,7 +6047,7 @@ package body Translation is if not Completion then Create_Array_Fat_Pointer (Info, Mode_Value); end if; - if Get_Signal_Type_Flag (Def) then + if Get_Has_Signal_Flag (Def) then Create_Array_Fat_Pointer (Info, Mode_Signal); end if; Finish_Type_Definition (Info, Completion); @@ -6083,6 +6115,7 @@ package body Translation is else -- Length is known. Create a constrained array. Info.Type_Mode := Type_Mode_Array; + Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; for I in Mode_Value .. Type_To_Last_Object_Kind (Def) loop case I is when Mode_Value => @@ -6342,6 +6375,7 @@ package body Translation is El := Get_Chain (El); end loop; + Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop Start_Record_Type (El_List); El := Get_Element_Declaration_Chain (Def); @@ -6355,9 +6389,6 @@ package body Translation is end loop; Finish_Record_Type (El_List, Info.Ortho_Type (Kind)); end loop; - if Get_Signal_Type_Flag (Def) = False then - Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; - end if; Info.Type_Mode := Type_Mode_Record; Finish_Type_Definition (Info); @@ -6717,7 +6748,6 @@ package body Translation is Chap2.Finish_Subprg_Instance_Use (Info.T.Prot_Final_Instance); Finish_Subprogram_Body; - end Translate_Protected_Type_Body_Subprograms; --------------- @@ -7355,7 +7385,7 @@ package body Translation is -- Declare subprograms. Id := Get_Identifier (Decl); Create_Builder_Subprogram_Decl (Tinfo, Id, Mode_Value); - if Get_Signal_Type_Flag (Def) then + if Get_Has_Signal_Flag (Def) then Create_Builder_Subprogram_Decl (Tinfo, Id, Mode_Signal); end if; @@ -7367,12 +7397,12 @@ package body Translation is case Get_Kind (Def) is when Iir_Kind_Array_Type_Definition => Create_Array_Type_Builder (Def, Mode_Value); - if Get_Signal_Type_Flag (Def) then + if Get_Has_Signal_Flag (Def) then Create_Array_Type_Builder (Def, Mode_Signal); end if; when Iir_Kind_Record_Type_Definition => Create_Record_Type_Builder (Def, Mode_Value); - if Get_Signal_Type_Flag (Def) then + if Get_Has_Signal_Flag (Def) then Create_Record_Type_Builder (Def, Mode_Signal); end if; when others => @@ -8758,12 +8788,9 @@ package body Translation is -- FIXME: to be improved ? -- Only required for transient types. - -- FIXME: check this (why open/close_temp ?) - Open_Temp; Define_Global_Const (Info.Object_Var, Chap7.Translate_Static_Expression (Val, Def)); - Close_Temp; end if; when others => Error_Kind ("create_objet", El); @@ -10170,40 +10197,6 @@ package body Translation is end case; end Translate_Declaration; - -- Mark FUNC (by adding the subprg_resolv info) iif it can be a - -- resolution function. - procedure Check_Resolution_Function (Func : Iir) - is - Param : Iir; - Param_Type : Iir; - Res_Type : Iir; - Info : Subprg_Info_Acc; - begin - Param := Get_Interface_Declaration_Chain (Func); - - -- Return now if the number of parameters is not 1. - if Param = Null_Iir or else Get_Chain (Param) /= Null_Iir then - return; - end if; - Param_Type := Get_Type (Param); - case Get_Kind (Param_Type) is - when Iir_Kind_Array_Type_Definition - | Iir_Kind_Unconstrained_Array_Subtype_Definition => - null; - when others => - return; - end case; - Res_Type := Get_Return_Type (Func); - if Get_Base_Type (Get_Element_Subtype (Param_Type)) - /= Get_Base_Type (Res_Type) - then - return; - end if; - -- FUNC can be a resolution function. - Info := Get_Info (Func); - Info.Subprg_Resolv := new Subprg_Resolv_Info; - end Check_Resolution_Function; - procedure Translate_Resolution_Function (Func : Iir; Block : Iir) is -- Type of the resolution function parameter. @@ -10592,8 +10585,10 @@ package body Translation is else Info := Add_Info (El, Kind_Subprg); Chap2.Translate_Subprogram_Interfaces (El); - if Get_Kind (El) = Iir_Kind_Function_Declaration then - Check_Resolution_Function (El); + if Get_Kind (El) = Iir_Kind_Function_Declaration + and then Get_Resolution_Function_Flag (El) + then + Info.Subprg_Resolv := new Subprg_Resolv_Info; end if; end if; when Iir_Kind_Function_Body @@ -12044,8 +12039,34 @@ package body Translation is Finish_If_Stmt (If_Blk); end Check_Bound_Error; + -- Return TRUE if an array whose index type is RNG_TYPE indexed by + -- an expression of type EXPR_TYPE needs a bound check. + function Need_Index_Check (Expr_Type : Iir; Rng_Type : Iir) + return Boolean + is + Rng : Iir; + begin + -- No check if the expression has the type of the index. + if Expr_Type = Rng_Type then + return False; + end if; + + -- No check for 'Range or 'Reverse_Range. + Rng := Get_Range_Constraint (Expr_Type); + if (Get_Kind (Rng) = Iir_Kind_Range_Array_Attribute + or Get_Kind (Rng) = Iir_Kind_Reverse_Range_Array_Attribute) + and then Get_Type (Rng) = Rng_Type + then + return False; + end if; + + return True; + end Need_Index_Check; + + function Translate_Index_To_Offset (Range_Ptr : O_Dnode; Index : O_Enode; + Index_Expr : Iir; Index_Type : Iir; Loc : Iir) return O_Enode @@ -12059,7 +12080,7 @@ package body Translation is Bound_Node : O_Dnode; Index_Info : Type_Info_Acc; begin - Index_Info := Get_Info (Index_Type); + Index_Info := Get_Info (Get_Base_Type (Index_Type)); Res := Create_Temp (Ghdl_Index_Type); @@ -12098,20 +12119,22 @@ package body Translation is Ghdl_Index_Type)); -- Check bounds. - Cond1 := New_Compare_Op - (ON_Lt, - New_Obj_Value (Off), - New_Lit (New_Signed_Literal (Index_Info.Ortho_Type (Mode_Value), - 0)), - Ghdl_Bool_Type); - - Cond2 := New_Compare_Op - (ON_Ge, - New_Obj_Value (Res), - New_Value_Selected_Acc_Value (New_Obj (Range_Ptr), - Index_Info.T.Range_Length), - Ghdl_Bool_Type); - Check_Bound_Error (New_Dyadic_Op (ON_Or, Cond1, Cond2), Loc, 0); + if Need_Index_Check (Get_Type (Index_Expr), Index_Type) then + Cond1 := New_Compare_Op + (ON_Lt, + New_Obj_Value (Off), + New_Lit (New_Signed_Literal (Index_Info.Ortho_Type (Mode_Value), + 0)), + Ghdl_Bool_Type); + + Cond2 := New_Compare_Op + (ON_Ge, + New_Obj_Value (Res), + New_Value_Selected_Acc_Value (New_Obj (Range_Ptr), + Index_Info.T.Range_Length), + Ghdl_Bool_Type); + Check_Bound_Error (New_Dyadic_Op (ON_Or, Cond1, Cond2), Loc, 0); + end if; Close_Temp; @@ -12250,8 +12273,7 @@ package body Translation is R := Translate_Index_To_Offset (M2Dp (Range_Ptr), Chap7.Translate_Expression (Index, Ibasetype), - Ibasetype, - Index); + Index, Itype, Index); when Type_Mode_Array => -- BASE is a thin array. R := Translate_Thin_Index_Offset (Itype, Dim, Index); @@ -12340,11 +12362,11 @@ package body Translation is Index_Type := Get_Nth_Element (Get_Index_Subtype_List (Prefix_Type), 0); + Kind := Get_Object_Kind (Prefix); + -- Evaluate slice bounds. Chap3.Create_Array_Subtype (Slice_Type, True); - Kind := Get_Object_Kind (Prefix); - Prefix_Info := Get_Info (Prefix_Type); Slice_Info := Get_Info (Slice_Type); @@ -12545,7 +12567,6 @@ package body Translation is end case; --Finish_If_Stmt (If_Blk); - end Translate_Slice_Name; function Translate_Interface_Name @@ -13403,7 +13424,8 @@ package body Translation is Formal_Base := Get_Base_Name (Formal); case Get_Kind (Formal_Base) is - when Iir_Kind_Constant_Interface_Declaration => + when Iir_Kind_Constant_Interface_Declaration + | Iir_Kind_File_Interface_Declaration => return Translate_Expression (Actual, Get_Type (Formal_Base)); when Iir_Kind_Signal_Interface_Declaration => return Translate_Implicit_Conv @@ -15757,34 +15779,93 @@ package body Translation is end case; end Translate_Expression; --- procedure Translate_Range_Expression --- (Res : O_Lnode; Expr : Iir; Range_Type : Iir) --- is --- T_Info : Type_Info_Acc; --- begin --- T_Info := Get_Info (Range_Type); --- Open_Temp; --- New_Assign_Stmt --- (New_Selected_Element (Res, T_Info.T.Range_Left), --- Chap7.Translate_Range_Expression_Left (Expr, Range_Type)); --- New_Assign_Stmt --- (New_Selected_Element (Res, T_Info.T.Range_Right), --- Chap7.Translate_Range_Expression_Right (Expr, Range_Type)); --- New_Assign_Stmt (New_Selected_Element (Res, T_Info.T.Range_Dir), --- Chap7.Translate_Static_Range_Dir (Expr)); --- if T_Info.T.Range_Length /= O_Fnode_Null then --- Open_Temp; --- New_Assign_Stmt (New_Selected_Element (Res, T_Info.T.Range_Length), --- Chap7.Translate_Range_Expression_Length (Expr)); --- Close_Temp; --- end if; --- Close_Temp; --- end Translate_Range_Expression; + -- Check if RNG is of the form: + -- 1 to T'length + -- or T'Length downto 1 + -- or 0 to T'length - 1 + -- or T'Length - 1 downto 0 + -- In either of these cases, return T'Length + function Is_Length_Range_Expression (Rng : Iir_Range_Expression) + return Iir + is + -- Pattern of a bound. + type Length_Pattern is + ( + Pat_Unknown, + Pat_Length, + Pat_Length_1, -- Length - 1 + Pat_1, + Pat_0 + ); + Length_Attr : Iir := Null_Iir; + + -- Classify the bound. + -- Set LENGTH_ATTR is the pattern is Pat_Length. + function Get_Length_Pattern (Expr : Iir; Recurse : Boolean) + return Length_Pattern + is + begin + case Get_Kind (Expr) is + when Iir_Kind_Length_Array_Attribute => + Length_Attr := Expr; + return Pat_Length; + when Iir_Kind_Integer_Literal => + case Get_Value (Expr) is + when 0 => + return Pat_0; + when 1 => + return Pat_1; + when others => + return Pat_Unknown; + end case; + when Iir_Kind_Substraction_Operator => + if not Recurse then + return Pat_Unknown; + end if; + if Get_Length_Pattern (Get_Left (Expr), False) = Pat_Length + and then + Get_Length_Pattern (Get_Right (Expr), False) = Pat_1 + then + return Pat_Length_1; + else + return Pat_Unknown; + end if; + when others => + return Pat_Unknown; + end case; + end Get_Length_Pattern; + Left_Pat, Right_Pat : Length_Pattern; + begin + Left_Pat := Get_Length_Pattern (Get_Left_Limit (Rng), True); + if Left_Pat = Pat_Unknown then + return Null_Iir; + end if; + Right_Pat := Get_Length_Pattern (Get_Right_Limit (Rng), True); + if Right_Pat = Pat_Unknown then + return Null_Iir; + end if; + case Get_Direction (Rng) is + when Iir_To => + if (Left_Pat = Pat_1 and Right_Pat = Pat_Length) + or else (Left_Pat = Pat_0 and Right_Pat = Pat_Length_1) + then + return Length_Attr; + end if; + when Iir_Downto => + if (Left_Pat = Pat_Length and Right_Pat = Pat_1) + or else (Left_Pat = Pat_Length_1 and Right_Pat = Pat_0) + then + return Length_Attr; + end if; + end case; + return Null_Iir; + end Is_Length_Range_Expression; procedure Translate_Range_Expression_Ptr (Res_Ptr : O_Dnode; Expr : Iir; Range_Type : Iir) is T_Info : Type_Info_Acc; + Length_Attr : Iir; begin T_Info := Get_Info (Range_Type); Open_Temp; @@ -15804,17 +15885,26 @@ package body Translation is T_Info.T.Range_Length), New_Lit (Translate_Static_Range_Length (Expr))); else - Open_Temp; - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Res_Ptr), - T_Info.T.Range_Length), - Compute_Range_Length - (New_Value_Selected_Acc_Value (New_Obj (Res_Ptr), - T_Info.T.Range_Left), - New_Value_Selected_Acc_Value (New_Obj (Res_Ptr), - T_Info.T.Range_Right), - Get_Direction (Expr))); - Close_Temp; + Length_Attr := Is_Length_Range_Expression (Expr); + if Length_Attr = Null_Iir then + Open_Temp; + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), + T_Info.T.Range_Length), + Compute_Range_Length + (New_Value_Selected_Acc_Value (New_Obj (Res_Ptr), + T_Info.T.Range_Left), + New_Value_Selected_Acc_Value (New_Obj (Res_Ptr), + T_Info.T.Range_Right), + Get_Direction (Expr))); + Close_Temp; + else + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), + T_Info.T.Range_Length), + Chap14.Translate_Length_Array_Attribute + (Length_Attr, Null_Iir)); + end if; end if; end if; Close_Temp; @@ -24406,20 +24496,24 @@ package body Translation is New_Record_Aggr_El (Aggr, New_Rti_Address (Base_Info.Type_Rti)); New_Record_Aggr_El (Aggr, Var_Acc_To_Loc (Bounds)); for I in Mode_Value .. Mode_Signal loop - if I = Mode_Signal and then not Get_Signal_Type_Flag (Atype) then - Val := Get_Null_Loc; - else - case Info.Type_Mode is - when Type_Mode_Array => + case Info.Type_Mode is + when Type_Mode_Array => + if Info.Ortho_Type (I) /= O_Tnode_Null then Val := New_Union_Aggr (Ghdl_Rti_Loc, Ghdl_Rti_Loc_Offset, New_Sizeof (Info.Ortho_Type (I), Ghdl_Index_Type)); - when Type_Mode_Ptr_Array => + else + Val := Get_Null_Loc; + end if; + when Type_Mode_Ptr_Array => + if Info.C.Size_Var (I) /= null then Val := Var_Acc_To_Loc (Info.C.Size_Var (I)); - when others => - Error_Kind ("generate_array_subtype_definition", Atype); - end case; - end if; + else + Val := Get_Null_Loc; + end if; + when others => + Error_Kind ("generate_array_subtype_definition", Atype); + end case; New_Record_Aggr_El (Aggr, Val); end loop; |