Allocate dynamic object in suspended procedures on stack2.

6 files changed, 82 insertions, 29 deletions

diff --git a/src/vhdl/translate/trans-chap2.adb b/src/vhdl/translate/trans-chap2.adb
index 3f62db739..7798c93a8 100644
--- a/src/vhdl/translate/trans-chap2.adb
+++ b/src/vhdl/translate/trans-chap2.adb
@@ -456,7 +456,7 @@ package body Trans.Chap2 is
       if Has_Nested or else Has_Suspend then
          --  Unnest subprograms.
          --  Create an instance for the local declarations.
-         Push_Instance_Factory (Info.Subprg_Frame_Scope'Access);
+         Push_Frame_Factory (Info.Subprg_Frame_Scope'Access);
          Add_Subprg_Instance_Field (Upframe_Field, Upframe_Scope);
 
          if Info.Subprg_Params_Ptr /= O_Tnode_Null then
@@ -510,7 +510,7 @@ package body Trans.Chap2 is
             Add_Scope_Field (Wki_Locvars, Info.Subprg_Locvars_Scope);
          end if;
 
-         Pop_Instance_Factory (Info.Subprg_Frame_Scope'Access);
+         Pop_Frame_Factory (Info.Subprg_Frame_Scope'Access);
 
          New_Type_Decl (Create_Identifier ("_FRAMETYPE"),
                         Get_Scope_Type (Info.Subprg_Frame_Scope));
diff --git a/src/vhdl/translate/trans-chap4.adb b/src/vhdl/translate/trans-chap4.adb
index ff3c3870c..676f13613 100644
--- a/src/vhdl/translate/trans-chap4.adb
+++ b/src/vhdl/translate/trans-chap4.adb
@@ -582,6 +582,13 @@ package body Trans.Chap4 is
    begin
       Elab_Object_Storage (Obj);
       Elab_Object_Init (Name, Obj, Value, Alloc_Kind);
+
+      if Alloc_Kind = Alloc_Return then
+         --  If the object is allocated on the return stack, avoid
+         --  deallocation.  Deallocation must be done manually (this concerns
+         --  procedures with suspension).
+         Disable_Stack2_Release;
+      end if;
    end Elab_Object_Value;
 
    --  Create code to elaborate OBJ.
diff --git a/src/vhdl/translate/trans-chap8.adb b/src/vhdl/translate/trans-chap8.adb
index c55f48de6..531007d8b 100644
--- a/src/vhdl/translate/trans-chap8.adb
+++ b/src/vhdl/translate/trans-chap8.adb
@@ -2120,7 +2120,7 @@ package body Trans.Chap8 is
       Push_Instance_Factory (Info.Call_State_Scope'Access);
 
       --  Variable for the frame.
-      Info.Call_Frame_Var := Create_Var (Create_Var_Identifier ("FRAME"),
+      Info.Call_Params_Var := Create_Var (Create_Var_Identifier ("PARAMS"),
                                          Get_Info (Imp).Subprg_Params_Type,
                                          O_Storage_Local);
       Info.Call_State_Mark := Create_Var (Create_Var_Identifier ("MARK"),
@@ -2581,7 +2581,7 @@ package body Trans.Chap8 is
          --  Save Stack2 mark.  Callee allocate its frame on stack2.
          if Is_Suspendable then
             --  The caller is suspendable.
-            Params_Var := Call_Info.Call_Frame_Var;
+            Params_Var := Call_Info.Call_Params_Var;
             Mark_Var := Call_Info.Call_State_Mark;
             --  There might be temporary variables created before the
             --  suspension, eg for range checks.
diff --git a/src/vhdl/translate/trans-helpers2.adb b/src/vhdl/translate/trans-helpers2.adb
index 500753bb5..11ea54042 100644
--- a/src/vhdl/translate/trans-helpers2.adb
+++ b/src/vhdl/translate/trans-helpers2.adb
@@ -129,8 +129,7 @@ package body Trans.Helpers2 is
    end Gen_Memcpy;
 
    function Gen_Alloc
-     (Kind : Allocation_Kind; Size : O_Enode; Ptype : O_Tnode)
-         return O_Enode
+     (Kind : Allocation_Kind; Size : O_Enode; Ptype : O_Tnode) return O_Enode
    is
       Constr : O_Assoc_List;
    begin
diff --git a/src/vhdl/translate/trans.adb b/src/vhdl/translate/trans.adb
index 6c8bc048e..4689150cc 100644
--- a/src/vhdl/translate/trans.adb
+++ b/src/vhdl/translate/trans.adb
@@ -241,6 +241,20 @@ package body Trans is
          New_Type_Decl (Name, Ptr_Type);
       end Declare_Scope_Acc;
 
+      --  Common routine for instance and frame.
+      procedure Start_Instance_Factory (Inst : Inst_Build_Acc) is
+      begin
+         Identifier_Start := Identifier_Len + 1;
+
+         if Inst.Scope.Scope_Type /= O_Tnode_Null then
+            Start_Uncomplete_Record_Type
+              (Inst.Scope.Scope_Type, Inst.Elements);
+         else
+            Start_Record_Type (Inst.Elements);
+         end if;
+         Inst_Build := Inst;
+      end Start_Instance_Factory;
+
       procedure Push_Instance_Factory (Scope : Var_Scope_Acc)
       is
          Inst : Inst_Build_Acc;
@@ -250,16 +264,21 @@ package body Trans is
          Inst.Prev_Id_Start := Identifier_Start;
          Inst.Scope := Scope;
 
-         Identifier_Start := Identifier_Len + 1;
-
-         if Scope.Scope_Type /= O_Tnode_Null then
-            Start_Uncomplete_Record_Type (Scope.Scope_Type, Inst.Elements);
-         else
-            Start_Record_Type (Inst.Elements);
-         end if;
-         Inst_Build := Inst;
+         Start_Instance_Factory (Inst);
       end Push_Instance_Factory;
 
+      procedure Push_Frame_Factory (Scope : Var_Scope_Acc)
+      is
+         Inst : Inst_Build_Acc;
+      begin
+         Inst := new Inst_Build_Type (Frame);
+         Inst.Prev := Inst_Build;
+         Inst.Prev_Id_Start := Identifier_Start;
+         Inst.Scope := Scope;
+
+         Start_Instance_Factory (Inst);
+      end Push_Frame_Factory;
+
       function Add_Instance_Factory_Field (Name : O_Ident; Ftype : O_Tnode)
                                            return O_Fnode
       is
@@ -285,19 +304,31 @@ package body Trans is
                               Child.Field, Otype);
       end Get_Scope_Offset;
 
-      procedure Pop_Instance_Factory (Scope : in Var_Scope_Acc)
+      procedure Finish_Instance_Factory (Scope : in Var_Scope_Acc)
       is
          Res : O_Tnode;
       begin
-         if Inst_Build.Kind /= Instance then
-            --  Not matching.
-            raise Internal_Error;
-         end if;
          Finish_Record_Type (Inst_Build.Elements, Res);
          Pop_Build_Instance;
          Scope.Scope_Type := Res;
+      end Finish_Instance_Factory;
+
+      procedure Pop_Instance_Factory (Scope : in Var_Scope_Acc) is
+      begin
+         --  Not matching.
+         pragma Assert (Inst_Build.Kind = Instance);
+
+         Finish_Instance_Factory (Scope);
       end Pop_Instance_Factory;
 
+      procedure Pop_Frame_Factory (Scope : in Var_Scope_Acc) is
+      begin
+         --  Not matching.
+         pragma Assert (Inst_Build.Kind = Frame);
+
+         Finish_Instance_Factory (Scope);
+      end Pop_Frame_Factory;
+
       procedure Push_Local_Factory
       is
          Inst : Inst_Build_Acc;
@@ -335,7 +366,8 @@ package body Trans is
          end if;
          case Inst_Build.Kind is
             when Local
-               | Instance =>
+              | Instance
+              | Frame =>
                return True;
             when Global =>
                return False;
@@ -496,11 +528,11 @@ package body Trans is
                --  Create a var.
                New_Var_Decl (Res, Name.Id, O_Storage_Local, Vtype);
                return Var_Type'(Kind => Var_Local, E => Res);
-            when Instance =>
+            when Instance | Frame =>
                --  Create a field.
                New_Record_Field (Inst_Build.Elements, Field, Name.Id, Vtype);
-               return Var_Type'(Kind => Var_Scope, I_Field => Field,
-                                I_Scope => Inst_Build.Scope);
+               return Var_Type'(Kind => Var_Scope, I_Build_Kind => K,
+                                I_Field => Field, I_Scope => Inst_Build.Scope);
          end case;
       end Create_Var;
 
@@ -592,9 +624,17 @@ package body Trans is
          case Var.Kind is
             when Var_Local =>
                return Alloc_Stack;
-            when Var_Global
-               | Var_Scope =>
+            when Var_Global =>
                return Alloc_System;
+            when Var_Scope =>
+               case Var.I_Build_Kind is
+                  when Frame =>
+                     return Alloc_Return;
+                  when Instance =>
+                     return Alloc_System;
+                  when others =>
+                     raise Internal_Error;
+               end case;
             when Var_None =>
                raise Internal_Error;
          end case;
@@ -1052,6 +1092,7 @@ package body Trans is
             when Var_Scope =>
                return Var_Type'
                  (Kind => Var_Scope,
+                  I_Build_Kind => Var.I_Build_Kind,
                   I_Field => Var.I_Field,
                   I_Scope => Instantiated_Var_Scope (Var.I_Scope));
          end case;
@@ -1906,7 +1947,6 @@ package body Trans is
 
       procedure Disable_Stack2_Release is
       begin
-         pragma Assert (not Temp_Level.No_Stack2_Mark);
          Temp_Level.No_Stack2_Mark := True;
       end Disable_Stack2_Release;
 
diff --git a/src/vhdl/translate/trans.ads b/src/vhdl/translate/trans.ads
index cc74d46b5..1d57e7ed0 100644
--- a/src/vhdl/translate/trans.ads
+++ b/src/vhdl/translate/trans.ads
@@ -259,6 +259,9 @@ package Trans is
       --  record type, that will be completed.
       procedure Push_Instance_Factory (Scope : Var_Scope_Acc);
 
+      --  Likewise but for a frame.
+      procedure Push_Frame_Factory (Scope : Var_Scope_Acc);
+
       --  Manually add a field to the current instance being built.
       function Add_Instance_Factory_Field (Name : O_Ident; Ftype : O_Tnode)
                                            return O_Fnode;
@@ -276,6 +279,7 @@ package Trans is
       --  Finish the building of the current instance and return the type
       --  built.
       procedure Pop_Instance_Factory (Scope : Var_Scope_Acc);
+      procedure Pop_Frame_Factory (Scope : Var_Scope_Acc);
 
       --  Create a new scope, in which variable are created locally
       --  (ie, on the stack).  Always created unlocked.
@@ -473,7 +477,7 @@ package Trans is
       --  are translated into functions.  The first argument of these functions
       --  is a pointer to the instance.
 
-      type Inst_Build_Kind_Type is (Local, Global, Instance);
+      type Inst_Build_Kind_Type is (Local, Global, Frame, Instance);
       type Inst_Build_Type (Kind : Inst_Build_Kind_Type);
       type Inst_Build_Acc is access Inst_Build_Type;
       type Inst_Build_Type (Kind : Inst_Build_Kind_Type) is record
@@ -485,7 +489,7 @@ package Trans is
                Prev_Global_Storage : O_Storage;
             when Global =>
                null;
-            when Instance =>
+            when Instance | Frame =>
                Scope               : Var_Scope_Acc;
                Elements            : O_Element_List;
          end case;
@@ -506,6 +510,9 @@ package Trans is
                | Var_Local =>
                E       : O_Dnode;
             when Var_Scope =>
+               --  To remember allocator for this variable.
+               I_Build_Kind : Inst_Build_Kind_Type;
+
                I_Field : O_Fnode;
                I_Scope : Var_Scope_Acc;
          end case;
@@ -1300,7 +1307,7 @@ package Trans is
          when Kind_Call =>
             Call_State_Scope : aliased Var_Scope_Type;
             Call_State_Mark : Var_Type := Null_Var;
-            Call_Frame_Var : Var_Type := Null_Var;
+            Call_Params_Var : Var_Type := Null_Var;
 
          when Kind_Call_Assoc =>
             --  Variable containing a reference to the actual, for scalar