diff options
-rw-r--r-- | src/ghdldrv/ghdlrun.adb | 2 | ||||
-rw-r--r-- | src/grt/grt-lib.adb | 9 | ||||
-rw-r--r-- | src/grt/grt-lib.ads | 3 | ||||
-rw-r--r-- | src/vhdl/translate/trans-chap6.adb | 76 | ||||
-rw-r--r-- | src/vhdl/translate/trans_decls.ads | 1 | ||||
-rw-r--r-- | src/vhdl/translate/translation.adb | 6 |
6 files changed, 66 insertions, 31 deletions
diff --git a/src/ghdldrv/ghdlrun.adb b/src/ghdldrv/ghdlrun.adb index 882698612..8cc1a6df0 100644 --- a/src/ghdldrv/ghdlrun.adb +++ b/src/ghdldrv/ghdlrun.adb @@ -325,6 +325,8 @@ package body Ghdlrun is Grt.Lib.Ghdl_Bound_Check_Failed'Address); Def (Trans_Decls.Ghdl_Direction_Check_Failed, Grt.Lib.Ghdl_Direction_Check_Failed'Address); + Def (Trans_Decls.Ghdl_Access_Check_Failed, + Grt.Lib.Ghdl_Access_Check_Failed'Address); Def (Trans_Decls.Ghdl_Integer_Index_Check_Failed, Grt.Lib.Ghdl_Integer_Index_Check_Failed'Address); diff --git a/src/grt/grt-lib.adb b/src/grt/grt-lib.adb index 13a0f1da4..f94c4b0c9 100644 --- a/src/grt/grt-lib.adb +++ b/src/grt/grt-lib.adb @@ -205,6 +205,15 @@ package body Grt.Lib is Error_E_Call_Stack (Bt); end Ghdl_Direction_Check_Failed; + procedure Ghdl_Access_Check_Failed + is + Bt : Backtrace_Addrs; + begin + Save_Backtrace (Bt, 1); + Error_S ("NULL access dereferenced"); + Error_E_Call_Stack (Bt); + end Ghdl_Access_Check_Failed; + procedure Diag_C_Range (Rng : Std_Integer_Range_Ptr) is begin Diag_C (Rng.Left); diff --git a/src/grt/grt-lib.ads b/src/grt/grt-lib.ads index 467cc4ca3..f8e7f0a7a 100644 --- a/src/grt/grt-lib.ads +++ b/src/grt/grt-lib.ads @@ -52,6 +52,7 @@ package Grt.Lib is Line: Ghdl_I32); procedure Ghdl_Direction_Check_Failed (Filename : Ghdl_C_String; Line: Ghdl_I32); + procedure Ghdl_Access_Check_Failed; procedure Ghdl_Integer_Index_Check_Failed (Filename : Ghdl_C_String; @@ -124,6 +125,8 @@ private "__ghdl_direction_check_failed"); pragma Export (C, Ghdl_Integer_Index_Check_Failed, "__ghdl_integer_index_check_failed"); + pragma Export (C, Ghdl_Access_Check_Failed, + "__ghdl_access_check_failed"); pragma Export (C, Ghdl_Program_Error, "__ghdl_program_error"); diff --git a/src/vhdl/translate/trans-chap6.adb b/src/vhdl/translate/trans-chap6.adb index 9d8b6ccab..608cab45a 100644 --- a/src/vhdl/translate/trans-chap6.adb +++ b/src/vhdl/translate/trans-chap6.adb @@ -1107,6 +1107,50 @@ package body Trans.Chap6 is end case; end Translate_Object_Alias_Name; + function Translate_Dereferenced_Name (Name : Iir) return Mnode + is + Name_Type : constant Iir := Get_Type (Name); + Type_Info : constant Type_Info_Acc := Get_Info (Name_Type); + Prefix : constant Iir := Get_Prefix (Name); + Prefix_Type : constant Iir := Get_Type (Prefix); + Pt_Info : constant Type_Info_Acc := Get_Info (Prefix_Type); + Pfx : O_Enode; + Pfx_Var : O_Dnode; + If_Blk : O_If_Block; + Constr : O_Assoc_List; + begin + Pfx := Chap7.Translate_Expression (Prefix); + if Pt_Info.Type_Mode = Type_Mode_Bounds_Acc then + Pfx_Var := Create_Temp_Init (Pt_Info.Ortho_Type (Mode_Value), Pfx); + + -- Check null access + -- There is no dereference (so no SEGV) for unbounded access, so + -- we need to add an explicit check. + -- Also, an implicit dereference is immediately followed by an + -- access, so check only in case of explicit dereference. + -- We could try to do a manual dereference but some backends (llvm) + -- optimize this check. + if Get_Kind (Name) = Iir_Kind_Dereference then + Start_If_Stmt + (If_Blk, + New_Compare_Op + (ON_Eq, New_Obj_Value (Pfx_Var), + New_Lit (New_Null_Access (Pt_Info.Ortho_Type (Mode_Value))), + Ghdl_Bool_Type)); + Start_Association (Constr, Ghdl_Access_Check_Failed); + New_Procedure_Call (Constr); + Finish_If_Stmt (If_Blk); + end if; + + return Chap7.Bounds_Acc_To_Fat_Pointer (Pfx_Var, Prefix_Type); + else + return Lv2M (New_Access_Element + (New_Convert_Ov + (Pfx, Type_Info.Ortho_Ptr_Type (Mode_Value))), + Type_Info, Mode_Value); + end if; + end Translate_Dereferenced_Name; + function Translate_Name (Name : Iir; Mode : Object_Kind_Type) return Mnode is Name_Type : constant Iir := Get_Type (Name); @@ -1201,37 +1245,7 @@ package body Trans.Chap6 is when Iir_Kind_Dereference | Iir_Kind_Implicit_Dereference => pragma Assert (Mode = Mode_Value); - declare - Prefix : constant Iir := Get_Prefix (Name); - Prefix_Type : constant Iir := Get_Type (Prefix); - Pt_Info : constant Type_Info_Acc := Get_Info (Prefix_Type); - Pfx : O_Enode; - Pfx_Var : O_Dnode; - Chk_Null : O_Dnode; - begin - Pfx := Chap7.Translate_Expression (Prefix); - if Pt_Info.Type_Mode = Type_Mode_Bounds_Acc then - Pfx_Var := Create_Temp_Init - (Pt_Info.Ortho_Type (Mode_Value), Pfx); - - -- Do a dummy memory access to catch null access. - Chk_Null := Create_Temp_Init - (Char_Type_Node, - New_Value (New_Access_Element - (New_Convert_Ov (New_Obj_Value (Pfx_Var), - Ghdl_Ptr_Type)))); - pragma Unreferenced (Chk_Null); - - return Chap7.Bounds_Acc_To_Fat_Pointer - (Pfx_Var, Prefix_Type); - else - return Lv2M - (New_Access_Element - (New_Convert_Ov - (Pfx, Type_Info.Ortho_Ptr_Type (Mode_Value))), - Type_Info, Mode_Value); - end if; - end; + return Translate_Dereferenced_Name (Name); when Iir_Kind_Selected_Element => return Translate_Selected_Element diff --git a/src/vhdl/translate/trans_decls.ads b/src/vhdl/translate/trans_decls.ads index da4a7c4b0..1aac95cff 100644 --- a/src/vhdl/translate/trans_decls.ads +++ b/src/vhdl/translate/trans_decls.ads @@ -188,6 +188,7 @@ package Trans_Decls is Ghdl_Bound_Check_Failed : O_Dnode; Ghdl_Integer_Index_Check_Failed : O_Dnode; Ghdl_Direction_Check_Failed : O_Dnode; + Ghdl_Access_Check_Failed : O_Dnode; -- Stack 2. Ghdl_Stack2_Allocate : O_Dnode; diff --git a/src/vhdl/translate/translation.adb b/src/vhdl/translate/translation.adb index e9f1d1095..5325e6276 100644 --- a/src/vhdl/translate/translation.adb +++ b/src/vhdl/translate/translation.adb @@ -636,6 +636,12 @@ package body Translation is New_Interface_Decl (Interfaces, Param, Wki_Line, Ghdl_I32_Type); Finish_Subprogram_Decl (Interfaces, Ghdl_Direction_Check_Failed); + -- procedure __ghdl_access_check_failed (); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_access_check_failed"), + O_Storage_External); + Finish_Subprogram_Decl (Interfaces, Ghdl_Access_Check_Failed); + -- Secondary stack subprograms. -- function __ghdl_stack2_allocate (size : ghdl_index_type) -- return ghdl_ptr_type; |