Add --max-stack-alloc option, check stack allocation of complex object.

Fix #692

9 files changed, 107 insertions, 1 deletions

diff --git a/src/ghdldrv/ghdlrun.adb b/src/ghdldrv/ghdlrun.adb
index 9d1e14343..c4d9cc3be 100644
--- a/src/ghdldrv/ghdlrun.adb
+++ b/src/ghdldrv/ghdlrun.adb
@@ -322,6 +322,8 @@ package body Ghdlrun is
            Grt.Lib.Ghdl_I32_Exp'Address);
       Def (Trans_Decls.Ghdl_I64_Exp,
            Grt.Lib.Ghdl_I64_Exp'Address);
+      Def (Trans_Decls.Ghdl_Check_Stack_Allocation,
+           Grt.Lib.Ghdl_Check_Stack_Allocation'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 7597bcfc4..0bb9c2e36 100644
--- a/src/grt/grt-lib.adb
+++ b/src/grt/grt-lib.adb
@@ -275,6 +275,19 @@ package body Grt.Lib is
       return Ghdl_I64_Exp_1 (V, E);
    end Ghdl_I64_Exp;
 
+   procedure Ghdl_Check_Stack_Allocation (Size : Ghdl_Index_Type)
+   is
+      Bt : Backtrace_Addrs;
+   begin
+      if Size >= Max_Stack_Allocation then
+         Save_Backtrace (Bt, 1);
+         Error_S ("declaration of a too large object (");
+         Diag_C (Natural (Size / 1024));
+         Diag_C (" KB)");
+         Error_E_Call_Stack (Bt);
+      end if;
+   end Ghdl_Check_Stack_Allocation;
+
    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 646cdd5fb..167ea98e5 100644
--- a/src/grt/grt-lib.ads
+++ b/src/grt/grt-lib.ads
@@ -70,6 +70,11 @@ package Grt.Lib is
    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;
 
+   --  Called before allocation of large (complex) objects.
+   procedure Ghdl_Check_Stack_Allocation (Size : Ghdl_Index_Type);
+
+   Max_Stack_Allocation : Ghdl_Index_Type := 128 * 1024;
+
    function Ghdl_Malloc (Size : Ghdl_Index_Type) return Ghdl_Ptr;
 
    --  Allocate and clear SIZE bytes.
@@ -122,6 +127,9 @@ private
                   "__ghdl_direction_check_failed");
    pragma Export (C, Ghdl_Program_Error, "__ghdl_program_error");
 
+   pragma Export (C, Ghdl_Check_Stack_Allocation,
+                  "__ghdl_check_stack_allocation");
+
    pragma Export (C, Ghdl_Malloc, "__ghdl_malloc");
    pragma Export (C, Ghdl_Malloc0, "__ghdl_malloc0");
    pragma Export (C, Ghdl_Deallocate, "__ghdl_deallocate");
diff --git a/src/grt/grt-options.adb b/src/grt/grt-options.adb
index 5b154e4a5..d93ad9e58 100644
--- a/src/grt/grt-options.adb
+++ b/src/grt/grt-options.adb
@@ -56,6 +56,7 @@ package body Grt.Options is
       P ("       X is expressed as a time value, without spaces: 1ns, ps...");
       P (" --stop-delta=X    stop the simulation cycle after X delta");
       P (" --expect-failure  invert exit status");
+      P (" --max-stack-alloc=X  error if variables are larger than X KB");
       P (" --no-run          do not simulate, only elaborate");
       P (" --unbuffered      disable buffering on stdout, stderr and");
       P ("                   files opened in write or append mode (TEXTIO).");
@@ -272,6 +273,21 @@ package body Grt.Options is
          Warning ("option --stack-size is deprecated");
       elsif Len >= 17 and then Option (1 .. 17) = "--stack-max-size=" then
          Warning ("option --stack-max-size is deprecated");
+      elsif Len >= 18 and then Option (1 .. 18) = "--max-stack-alloc=" then
+         declare
+            Ok : Boolean;
+            Pos : Natural;
+            Val : Integer_64;
+         begin
+            Extract_Integer (Option (19 .. Len), Ok, Val, Pos);
+            if not Ok or else Pos <= Len then
+               Error_S ("bad value in '");
+               Diag_C (Option);
+               Error_E ("'");
+            else
+               Lib.Max_Stack_Allocation := Ghdl_Index_Type (Val * 1024);
+            end if;
+         end;
       elsif Len >= 11 and then Option (1 .. 11) = "--activity=" then
          if Option (12 .. Len) = "none" then
             Flag_Activity := Activity_None;
diff --git a/src/vhdl/translate/trans-chap4.adb b/src/vhdl/translate/trans-chap4.adb
index 73f8aa4e1..675dc3d62 100644
--- a/src/vhdl/translate/trans-chap4.adb
+++ b/src/vhdl/translate/trans-chap4.adb
@@ -447,6 +447,40 @@ package body Trans.Chap4 is
       end case;
    end Init_Object;
 
+   --  If SIZE is larger than the threshold, call __ghdl_check_stack_allocation
+   --  to raise an error if the size is too large.  There are two threshold:
+   --  one set at compile time (Check_Stack_Allocation_Threshold) and one set
+   --  at run-time.
+   --
+   --  Right now, this function is called only for allocation of a complex
+   --  object on the stack (constant or variable).  But there are more sources
+   --  of stack allocation (temporary aggregate, unbounded objects, individual
+   --  assocs...)
+   function Maybe_Check_Stack_Allocation (Size : O_Enode) return O_Enode
+   is
+      Val : O_Dnode;
+      If_Blk : O_If_Block;
+      Assoc : O_Assoc_List;
+   begin
+      if Flag_Check_Stack_Allocation = 0 then
+         return Size;
+      end if;
+
+      Val := Create_Temp_Init (Ghdl_Index_Type, Size);
+      Start_If_Stmt
+        (If_Blk,
+         New_Compare_Op (ON_Ge,
+                         New_Obj_Value (Val),
+                         New_Lit (Check_Stack_Allocation_Threshold),
+                         Ghdl_Bool_Type));
+      Start_Association (Assoc, Ghdl_Check_Stack_Allocation);
+      New_Association (Assoc, New_Obj_Value (Val));
+      New_Procedure_Call (Assoc);
+      Finish_If_Stmt (If_Blk);
+
+      return New_Obj_Value (Val);
+   end Maybe_Check_Stack_Allocation;
+
    procedure Elab_Object_Storage (Obj : Iir)
    is
       Obj_Type : constant Iir := Get_Type (Obj);
@@ -456,6 +490,7 @@ package body Trans.Chap4 is
 
       Type_Info  : Type_Info_Acc;
       Alloc_Kind : Allocation_Kind;
+      Size : O_Enode;
    begin
       --  Elaborate subtype.
       Chap3.Elab_Object_Subtype (Obj_Type);
@@ -476,7 +511,16 @@ package body Trans.Chap4 is
          --  the object is a constant
          Name_Node := Get_Var (Obj_Info.Object_Var, Type_Info, Mode_Value);
          Alloc_Kind := Get_Alloc_Kind_For_Var (Obj_Info.Object_Var);
-         Allocate_Complex_Object (Obj_Type, Alloc_Kind, Name_Node);
+         Size := Chap3.Get_Subtype_Size (Obj_Type, Mnode_Null, Mode_Value);
+         if Alloc_Kind = Alloc_Stack then
+            Size := Maybe_Check_Stack_Allocation (Size);
+         end if;
+         --  Was: Allocate_Complex_Object.
+         New_Assign_Stmt
+           (M2Lp (Name_Node),
+            Gen_Alloc (Alloc_Kind,
+                       Size,
+                       Type_Info.Ortho_Ptr_Type (Mode_Value)));
       end if;
    end Elab_Object_Storage;
 
diff --git a/src/vhdl/translate/trans.ads b/src/vhdl/translate/trans.ads
index f154d6d5d..aa6102e5c 100644
--- a/src/vhdl/translate/trans.ads
+++ b/src/vhdl/translate/trans.ads
@@ -138,6 +138,8 @@ package Trans is
    Ghdl_Signal_Ptr     : O_Tnode;
    Ghdl_Signal_Ptr_Ptr : O_Tnode;
 
+   Check_Stack_Allocation_Threshold : O_Cnode;
+
    type Object_Kind_Type is (Mode_Value, Mode_Signal);
 
    --  Well known identifiers.
diff --git a/src/vhdl/translate/trans_decls.ads b/src/vhdl/translate/trans_decls.ads
index 2f9fa539a..38d3be7e7 100644
--- a/src/vhdl/translate/trans_decls.ads
+++ b/src/vhdl/translate/trans_decls.ads
@@ -23,6 +23,8 @@ package Trans_Decls is
    Ghdl_Ieee_Assert_Failed : O_Dnode;
    Ghdl_Psl_Assert_Failed : O_Dnode;
 
+   Ghdl_Check_Stack_Allocation : O_Dnode;
+
    Ghdl_Psl_Cover : O_Dnode;
    Ghdl_Psl_Cover_Failed : O_Dnode;
    --  Procedure for report statement.
diff --git a/src/vhdl/translate/translation.adb b/src/vhdl/translate/translation.adb
index 2edeba0be..0999e792e 100644
--- a/src/vhdl/translate/translation.adb
+++ b/src/vhdl/translate/translation.adb
@@ -15,6 +15,7 @@
 --  along with GCC; see the file COPYING.  If not, write to the Free
 --  Software Foundation, 59 Temple Place - Suite 330, Boston, MA
 --  02111-1307, USA.
+with Interfaces; use Interfaces;
 with Ortho_Nodes; use Ortho_Nodes;
 with Ortho_Ident; use Ortho_Ident;
 with Flags; use Flags;
@@ -1079,6 +1080,20 @@ package body Translation is
          Create_Report_Subprg ("__ghdl_report", Ghdl_Report);
       end;
 
+      --  procedure __ghdl_check_stack_allocation (size : __ghdl_index_type)
+      Start_Procedure_Decl
+        (Interfaces, Get_Identifier ("__ghdl_check_stack_allocation"),
+         O_Storage_External);
+      New_Interface_Decl (Interfaces, Param, Wki_Val, Ghdl_Index_Type);
+      Finish_Subprogram_Decl (Interfaces, Ghdl_Check_Stack_Allocation);
+
+      if Flag_Check_Stack_Allocation > 0 then
+         Check_Stack_Allocation_Threshold :=
+           New_Index_Lit (Unsigned_64 (Flag_Check_Stack_Allocation));
+      else
+         Check_Stack_Allocation_Threshold := O_Cnode_Null;
+      end if;
+
       --  procedure __ghdl_text_write (file : __ghdl_file_index;
       --                               str  : std_string_ptr);
       Start_Procedure_Decl
diff --git a/src/vhdl/translate/translation.ads b/src/vhdl/translate/translation.ads
index 4c9b2ff27..ffaabd3bf 100644
--- a/src/vhdl/translate/translation.ads
+++ b/src/vhdl/translate/translation.ads
@@ -80,6 +80,10 @@ package Translation is
    --  support nested subprograms.
    Flag_Unnest_Subprograms : Boolean := False;
 
+   --  If > 0, emit a call for large dynamic allocation on the stack.  Large
+   --  defined by the value.
+   Flag_Check_Stack_Allocation : Natural := 32 * 1024;
+
    type Foreign_Kind_Type is (Foreign_Unknown,
                               Foreign_Vhpidirect,
                               Foreign_Intrinsic);