diff options
author | Tristan Gingold <tgingold@free.fr> | 2018-11-14 06:39:53 +0100 |
---|---|---|
committer | Tristan Gingold <tgingold@free.fr> | 2018-11-14 06:39:53 +0100 |
commit | 279fcbc246fc6438756b76cd4d3d5f1f3e4e1463 (patch) | |
tree | 3a11f301175db7618893a14726a1bf55e2e802c1 /src | |
parent | fe338385f6c077e5b55b1fa2fc0fe4033894857d (diff) | |
download | ghdl-279fcbc246fc6438756b76cd4d3d5f1f3e4e1463.tar.gz ghdl-279fcbc246fc6438756b76cd4d3d5f1f3e4e1463.tar.bz2 ghdl-279fcbc246fc6438756b76cd4d3d5f1f3e4e1463.zip |
Fix overflow detection for **, implement ** for i64.
Fix #683
Diffstat (limited to 'src')
-rw-r--r-- | src/ghdldrv/ghdlrun.adb | 6 | ||||
-rw-r--r-- | src/grt/grt-lib.adb | 73 | ||||
-rw-r--r-- | src/grt/grt-lib.ads | 7 | ||||
-rw-r--r-- | src/grt/grt-types.ads | 3 | ||||
-rw-r--r-- | src/vhdl/translate/trans-chap3.adb | 3 | ||||
-rw-r--r-- | src/vhdl/translate/trans-chap7.adb | 23 | ||||
-rw-r--r-- | src/vhdl/translate/trans.ads | 3 | ||||
-rw-r--r-- | src/vhdl/translate/trans_decls.ads | 3 | ||||
-rw-r--r-- | src/vhdl/translate/translation.adb | 23 |
9 files changed, 112 insertions, 32 deletions
diff --git a/src/ghdldrv/ghdlrun.adb b/src/ghdldrv/ghdlrun.adb index d612095f7..9d1e14343 100644 --- a/src/ghdldrv/ghdlrun.adb +++ b/src/ghdldrv/ghdlrun.adb @@ -318,8 +318,10 @@ package body Ghdlrun is Grt.Lib.Ghdl_Deallocate'Address); Def (Trans_Decls.Ghdl_Real_Exp, Grt.Lib.Ghdl_Real_Exp'Address); - Def (Trans_Decls.Ghdl_Integer_Exp, - Grt.Lib.Ghdl_Integer_Exp'Address); + Def (Trans_Decls.Ghdl_I32_Exp, + Grt.Lib.Ghdl_I32_Exp'Address); + Def (Trans_Decls.Ghdl_I64_Exp, + Grt.Lib.Ghdl_I64_Exp'Address); Def (Trans_Decls.Ghdl_Sensitized_Process_Register, Grt.Processes.Ghdl_Sensitized_Process_Register'Address); diff --git a/src/grt/grt-lib.adb b/src/grt/grt-lib.adb index 2442998fe..3a9a9f6c3 100644 --- a/src/grt/grt-lib.adb +++ b/src/grt/grt-lib.adb @@ -191,16 +191,53 @@ package body Grt.Lib is Error_E_Call_Stack (Bt); end Ghdl_Direction_Check_Failed; - function Ghdl_Integer_Exp (V : Ghdl_I32; E : Ghdl_I32) - return Ghdl_I32 - is - pragma Suppress (Overflow_Check); + function Hi (V : Ghdl_I64) return Ghdl_U32 is + begin + return Ghdl_U32 (Shift_Right (To_Ghdl_U64 (V), 32) and 16#ffff_ffff#); + end Hi; - R : Ghdl_I32; - Res : Ghdl_I32; - P : Ghdl_I32; + function Lo (V : Ghdl_I64) return Ghdl_U32 is + begin + return Ghdl_U32 (To_Ghdl_U64 (V) and 16#ffff_ffff#); + end Lo; + + procedure Mul_I32_Ovf (L, R : Ghdl_I32; + Res : out Ghdl_I32; + Ovf : out Boolean) + is T : Ghdl_I64; begin + T := Ghdl_I64 (L) * Ghdl_I64 (R); + if Hi (T) /= Shift_Right_Arithmetic (Lo (T), 31) then + Ovf := True; + else + Ovf := False; + Res := Ghdl_I32 (T); + end if; + end Mul_I32_Ovf; + + procedure Mul_I64_Ovf (L, R : Ghdl_I64; + Res : out Ghdl_I64; + Ovf : out Boolean) is + begin + -- TODO: check overflow. + Res := L * R; + Ovf := False; + end Mul_I64_Ovf; + + generic + type T is range <>; + with procedure Mul_Ovf (L, R : T; Res : out T; Ovf : out Boolean); + function Gen_Ixx_Exp (V : T; E : Std_Integer) return T; + pragma Convention (C, Gen_Ixx_Exp); + + function Gen_Ixx_Exp (V : T; E : Std_Integer) return T + is + R : Std_Integer; + Res : T; + P : T; + Ovf : Boolean; + begin if E < 0 then Error ("negative exponent"); end if; @@ -209,18 +246,30 @@ package body Grt.Lib is R := E; loop if R mod 2 = 1 then - T := Ghdl_I64 (Res) * Ghdl_I64 (P); - Res := Ghdl_I32 (T); - if Ghdl_I64 (Res) /= T then + Mul_Ovf (Res, P, Res, Ovf); + if Ovf then Error ("overflow in exponentiation"); end if; end if; R := R / 2; exit when R = 0; - P := P * P; + Mul_Ovf (P, P, P, Ovf); + if Ovf then + Error ("overflow in exponentiation"); + end if; end loop; return Res; - end Ghdl_Integer_Exp; + end Gen_Ixx_Exp; + + function Ghdl_I32_Exp_1 is new Gen_Ixx_Exp (Ghdl_I32, Mul_I32_Ovf); + + function Ghdl_I32_Exp (V : Ghdl_I32; E : Std_Integer) return Ghdl_I32 + renames Ghdl_I32_Exp_1; + + function Ghdl_I64_Exp_1 is new Gen_Ixx_Exp (Ghdl_I64, Mul_I64_Ovf); + + function Ghdl_I64_Exp (V : Ghdl_I64; E : Std_Integer) return Ghdl_I64 + renames Ghdl_I64_Exp_1; function C_Malloc (Size : Ghdl_Index_Type) return Ghdl_Ptr; pragma Import (C, C_Malloc, "malloc"); diff --git a/src/grt/grt-lib.ads b/src/grt/grt-lib.ads index 69c8a4c34..646cdd5fb 100644 --- a/src/grt/grt-lib.ads +++ b/src/grt/grt-lib.ads @@ -67,8 +67,8 @@ package Grt.Lib is Line : Ghdl_I32; Code : Ghdl_Index_Type); - function Ghdl_Integer_Exp (V : Ghdl_I32; E : Ghdl_I32) - return Ghdl_I32; + function Ghdl_I32_Exp (V : Ghdl_I32; E : Std_Integer) return Ghdl_I32; + function Ghdl_I64_Exp (V : Ghdl_I64; E : Std_Integer) return Ghdl_I64; function Ghdl_Malloc (Size : Ghdl_Index_Type) return Ghdl_Ptr; @@ -126,7 +126,8 @@ private pragma Export (C, Ghdl_Malloc0, "__ghdl_malloc0"); pragma Export (C, Ghdl_Deallocate, "__ghdl_deallocate"); - pragma Export (C, Ghdl_Integer_Exp, "__ghdl_integer_exp"); + pragma Export (C, Ghdl_I32_Exp, "__ghdl_i32_exp"); + pragma Export (C, Ghdl_I64_Exp, "__ghdl_i64_exp"); pragma Export (C, Ghdl_Real_Exp, "__ghdl_real_exp"); pragma Export (C, Ghdl_Std_Ulogic_To_Boolean_Array, diff --git a/src/grt/grt-types.ads b/src/grt/grt-types.ads index f75711eeb..fdabf4368 100644 --- a/src/grt/grt-types.ads +++ b/src/grt/grt-types.ads @@ -39,6 +39,9 @@ package Grt.Types is type Ghdl_U64 is new Unsigned_64; type Ghdl_F64 is new IEEE_Float_64; + function To_Ghdl_U64 is new Ada.Unchecked_Conversion + (Ghdl_I64, Ghdl_U64); + type Ghdl_Ptr is new Address; type Ghdl_Index_Type is mod 2 ** 32; subtype Ghdl_Real is Ghdl_F64; diff --git a/src/vhdl/translate/trans-chap3.adb b/src/vhdl/translate/trans-chap3.adb index c9e639dd1..7938a278d 100644 --- a/src/vhdl/translate/trans-chap3.adb +++ b/src/vhdl/translate/trans-chap3.adb @@ -3233,8 +3233,7 @@ package body Trans.Chap3 is Allocate_Unbounded_Composite_Bounds (Alloc_Kind, Res, Obj_Type); Copy_Bounds (Chap3.Get_Composite_Bounds (Res), Bounds, Obj_Type); -- Allocate base. - Allocate_Unbounded_Composite_Base - (Alloc_Kind, Res, Obj_Type); + Allocate_Unbounded_Composite_Base (Alloc_Kind, Res, Obj_Type); else New_Assign_Stmt (M2Lp (Res), diff --git a/src/vhdl/translate/trans-chap7.adb b/src/vhdl/translate/trans-chap7.adb index 20f7185d1..a0352a4dd 100644 --- a/src/vhdl/translate/trans-chap7.adb +++ b/src/vhdl/translate/trans-chap7.adb @@ -2456,11 +2456,24 @@ package body Trans.Chap7 is Right_Tree, Ghdl_Real_Exp); return New_Convert_Ov (Res, Res_Otype); when Iir_Predefined_Integer_Exp => - Res := Translate_Lib_Operator - (New_Convert_Ov (Left_Tree, Std_Integer_Otype), - Right_Tree, - Ghdl_Integer_Exp); - return New_Convert_Ov (Res, Res_Otype); + declare + Left_Tinfo : constant Type_Info_Acc := + Get_Info (Get_Type (Left)); + Opr : O_Dnode; + Etype : O_Tnode; + begin + case Type_Mode_Integers (Left_Tinfo.Type_Mode) is + when Type_Mode_I32 => + Opr := Ghdl_I32_Exp; + Etype := Ghdl_I32_Type; + when Type_Mode_I64 => + Opr := Ghdl_I64_Exp; + Etype := Ghdl_I64_Type; + end case; + Res := Translate_Lib_Operator + (New_Convert_Ov (Left_Tree, Etype), Right_Tree, Opr); + return New_Convert_Ov (Res, Res_Otype); + end; when Iir_Predefined_Array_Inequality | Iir_Predefined_Record_Inequality => diff --git a/src/vhdl/translate/trans.ads b/src/vhdl/translate/trans.ads index 960323ee8..f154d6d5d 100644 --- a/src/vhdl/translate/trans.ads +++ b/src/vhdl/translate/trans.ads @@ -1063,6 +1063,9 @@ package Trans is subtype Type_Mode_Scalar is Type_Mode_Type range Type_Mode_B1 .. Type_Mode_F64; + subtype Type_Mode_Integers is Type_Mode_Type range + Type_Mode_I32 .. Type_Mode_I64; + -- Composite types, with the vhdl meaning: record and arrays. subtype Type_Mode_Composite is Type_Mode_Type range Type_Mode_Static_Record .. Type_Mode_Protected; diff --git a/src/vhdl/translate/trans_decls.ads b/src/vhdl/translate/trans_decls.ads index d0011e653..2f9fa539a 100644 --- a/src/vhdl/translate/trans_decls.ads +++ b/src/vhdl/translate/trans_decls.ads @@ -164,7 +164,8 @@ package Trans_Decls is Ghdl_Malloc : O_Dnode; Ghdl_Malloc0 : O_Dnode; Ghdl_Real_Exp : O_Dnode; - Ghdl_Integer_Exp : O_Dnode; + Ghdl_I32_Exp : O_Dnode; + Ghdl_I64_Exp : O_Dnode; -- Procedure called in case of check failed. Ghdl_Program_Error : O_Dnode; diff --git a/src/vhdl/translate/translation.adb b/src/vhdl/translate/translation.adb index 68dd9a300..2edeba0be 100644 --- a/src/vhdl/translate/translation.adb +++ b/src/vhdl/translate/translation.adb @@ -1139,16 +1139,25 @@ package body Translation is Std_Integer_Otype); Finish_Subprogram_Decl (Interfaces, Ghdl_Real_Exp); - -- function __ghdl_integer_exp (left : std__standard__integer; - -- right : std__standard__integer) - -- return std__standard__integer; + -- function __ghdl_i32_exp (left : ghdl_i32; + -- right : std__standard__integer) + -- return ghdl_i32; Start_Function_Decl - (Interfaces, Get_Identifier ("__ghdl_integer_exp"), O_Storage_External, - Std_Integer_Otype); - New_Interface_Decl (Interfaces, Param, Wki_Left, Std_Integer_Otype); + (Interfaces, Get_Identifier ("__ghdl_i32_exp"), O_Storage_External, + Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Wki_Left, Ghdl_I32_Type); New_Interface_Decl (Interfaces, Param, Wki_Right, Std_Integer_Otype); - Finish_Subprogram_Decl (Interfaces, Ghdl_Integer_Exp); + Finish_Subprogram_Decl (Interfaces, Ghdl_I32_Exp); + -- function __ghdl_i64_exp (left : ghdl_i64; + -- right : std__standard__integer) + -- return ghdl_i64; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_i64_exp"), O_Storage_External, + Ghdl_I64_Type); + New_Interface_Decl (Interfaces, Param, Wki_Left, Ghdl_I64_Type); + New_Interface_Decl (Interfaces, Param, Wki_Right, Std_Integer_Otype); + Finish_Subprogram_Decl (Interfaces, Ghdl_I64_Exp); -- procedure __ghdl_image_b1 (res : std_string_ptr_node; -- val : ghdl_bool_type; |