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

Fix #692

5 files changed, 68 insertions, 1 deletions

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);