translate: adjust null access check: add an explicit check.

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;