diff mbox

[Ada] Exception during finalization of controlled object

Message ID 20140206095307.GA27750@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet Feb. 6, 2014, 9:53 a.m. UTC 
This patch corrects the finalization machinery to properly handle a controlled
object that is initialized by an aggregate and acts as a transient. The object
is now considered fully initialized after the last component assignment takes
place. This avoids the finalization of uninitialized data that may lead to a
Segmentation_Fault.

------------
-- Source --
------------

--  types.ads

with Ada.Finalization; use Ada.Finalization;

package Types is
   Bomb     : exception;
   Not_Zero : exception;

   procedure Set_Calls (Bomb_On : Natural);

   function New_Id return Natural;

   type Zero is new Natural range 0 .. 0;

   type Ctrl_Component is new Controlled with record
      Id   : Natural := 0;
      Data : Zero    := 0;
   end record;

   procedure Adjust     (Obj : in out Ctrl_Component);
   procedure Finalize   (Obj : in out Ctrl_Component);
   procedure Initialize (Obj : in out Ctrl_Component);

   function Make_Component return Ctrl_Component;

   type Ctrl_Encapsulator is new Controlled with record
      Id     : Natural := 0;
      Comp_1 : Ctrl_Component;
      Comp_2 : Ctrl_Component;
      Comp_3 : Ctrl_Component;
   end record;

   procedure Adjust     (Obj : in out Ctrl_Encapsulator);
   procedure Finalize   (Obj : in out Ctrl_Encapsulator);
   procedure Initialize (Obj : in out Ctrl_Encapsulator);

   type Encapsulator is record
      Id     : Natural := 0;
      Comp_1 : Ctrl_Component;
      Comp_2 : Ctrl_Component;
      Comp_3 : Ctrl_Component;
   end record;

   type Super_Encapsulator is record
      Id     : Natural := 0;
      Comp_1 : Ctrl_Encapsulator;
      Comp_2 : Ctrl_Encapsulator;
      Comp_3 : Ctrl_Encapsulator;
   end record;
end Types;

--  types.adb

with Ada.Text_IO; use Ada.Text_IO;

package body Types is
   Calls         : Natural := 0;
   Calls_To_Bomb : Natural := 0;
   Id_Gen        : Natural := 0;

   procedure Adjust (Obj : in out Ctrl_Component) is
      Old_Id : constant Natural := Obj.Id;
      New_Id : constant Natural := Old_Id * 100;

   begin
      Put_Line ("  adj comp" & Old_Id'Img & " ->" & New_Id'Img);
      Obj.Id := New_Id;
   end Adjust;

   procedure Adjust (Obj : in out Ctrl_Encapsulator) is
      Old_Id : constant Natural := Obj.Id;
      New_Id : constant Natural := Old_Id * 100;

   begin
      Put_Line ("  adj enca" & Old_Id'Img & " ->" & New_Id'Img);
      Obj.Id := New_Id;
   end Adjust;

   procedure Finalize (Obj : in out Ctrl_Component) is
   begin
      Put_Line ("  fin comp" & Obj.Id'Img);
      if Obj.Data /= 0 then
         raise Not_Zero;
      end if;
   end Finalize;

   procedure Finalize (Obj : in out Ctrl_Encapsulator) is
   begin
      Put_Line ("  fin enca" & Obj.Id'Img);
   end Finalize;

   procedure Initialize (Obj : in out Ctrl_Component) is
   begin
      Obj.Id := New_Id;
      Put_Line ("  ini comp" & Obj.Id'Img);
   end Initialize;

   procedure Initialize (Obj : in out Ctrl_Encapsulator) is
   begin
      Obj.Id := New_Id;
      Put_Line ("  ini comp" & Obj.Id'Img);
   end Initialize;

   function Make_Component return Ctrl_Component is
   begin
      if Calls = Calls_To_Bomb then
         raise Bomb;
      else
         Calls := Calls + 1;
      end if;

      declare
         Result : Ctrl_Component;
      begin
         return Result;
      end;
   end Make_Component;

   function New_Id return Natural is
   begin
      Id_Gen := Id_Gen + 1;
      return Id_Gen;
   end New_Id;

   procedure Set_Calls (Bomb_On : Natural) is
   begin
      Calls := 0;

      if Bomb_On >= 1 then
         Calls_To_Bomb := Bomb_On - 1;
      else
         Calls_To_Bomb := 0;
      end if;
   end Set_Calls;
end Types;

--  aggregates.adb

with Ada.Finalization; use Ada.Finalization;
with Ada.Text_IO;      use Ada.Text_IO;
with Types;            use Types;

procedure Aggregates is
begin
   Put_Line ("Test 4");
   Set_Calls (3);
   begin
      declare
         function Make_Encapsulator return Ctrl_Encapsulator is
         begin
            return Result : Ctrl_Encapsulator :=
                              (Controlled with
                               Id     => New_Id,
                               Comp_1 => Make_Component,
                               Comp_2 => Make_Component,
                               Comp_3 => Make_Component);
         end Make_Encapsulator;

         Obj : Ctrl_Encapsulator;

      begin
         Obj := Make_Encapsulator;
         Put_Line ("ERROR: Test 4: Bomb not raised");
      end;
   exception
      when Bomb     => null;
      when Not_Zero => Put_Line ("ERROR: Test 4: Not_Zero raised");
      when others   => Put_Line ("ERROR: Test 4: unexpected exception");
   end;
   Put_Line ("Test 4 end");

   Put_Line ("Test 5");
   Set_Calls (2);
   begin
      declare
         procedure Do_Nothing (Obj : Ctrl_Encapsulator) is
         begin
            null;
         end Do_Nothing;
      begin
         Do_Nothing
           (Ctrl_Encapsulator'
              (Controlled with
               Id     => New_Id,
               Comp_1 => Make_Component,
               Comp_2 => Make_Component,
               Comp_3 => Make_Component));
         Put_Line ("ERROR: Test 5: Bomb not raised");
      end;
   exception
      when Bomb     => null;
      when Not_Zero => Put_Line ("ERROR: Test 5: Not_Zero raised");
      when others   => Put_Line ("ERROR: Test 5: unexpected exception");
   end;
   Put_Line ("Test 5 end");

   Put_Line ("Test 6");
   Set_Calls (2);
   begin
      declare
         procedure Do_Nothing (Obj : out Ctrl_Encapsulator) is
         begin
            Obj := Ctrl_Encapsulator'
                     (Controlled with
                      Id     => New_Id,
                      Comp_1 => Make_Component,
                      Comp_2 => Make_Component,
                      Comp_3 => Make_Component);
            Put_Line ("ERROR: Test 6: Bomb not raised");
         end Do_Nothing;

         Obj : Ctrl_Encapsulator;

      begin
         Do_Nothing (Obj);
         Put_Line ("ERROR: Test 6: Bomb not raised");
      end;
   exception
      when Bomb     => null;
      when Not_Zero => Put_Line ("ERROR: Test 6: Not_Zero raised");
      when others   => Put_Line ("ERROR: Test 6: unexpected exception");
   end;
   Put_Line ("Test 6 end");

   Put_Line ("Test 7");
   Set_Calls (3);
   begin
      declare
         Obj : Ctrl_Encapsulator;

      begin
         Obj := Ctrl_Encapsulator'
                  (Controlled with
                   Id     => New_Id,
                   Comp_1 => Make_Component,
                   Comp_2 => Make_Component,
                   Comp_3 => Make_Component);
         Put_Line ("ERROR: Test 7: Bomb not raised");
      end;
   exception
      when Bomb     => null;
      when Not_Zero => Put_Line ("ERROR: Test 7: Not_Zero raised");
      when others   => Put_Line ("ERROR: Test 7: unexpected exception");
   end;
   Put_Line ("Test 7 end");

   Put_Line ("Test 8");
   Set_Calls (2);
   begin
      begin
         if New_Id > 0
           and then Ctrl_Encapsulator'
                      (Controlled with
                       Id     => New_Id,
                       Comp_1 => Make_Component,
                       Comp_2 => Make_Component,
                       Comp_3 => Make_Component).Comp_3.Data > 0
         then
            Put_Line ("ERROR: Test 8: Bomb not raised");
         else
            Put_Line ("ERROR: Test 8: Bomb not raised");
         end if;
      end;
   exception
      when Bomb     => null;
      when Not_Zero => Put_Line ("ERROR: Test 8: Not_Zero raised");
      when others   => Put_Line ("ERROR: Test 8: unexpected exception");
   end;
   Put_Line ("Test 8 end");

   Put_Line ("Test 9");
   Set_Calls (3);
   begin
      begin
         case Ctrl_Encapsulator'
                (Controlled with
                 Id     => New_Id,
                 Comp_1 => Make_Component,
                 Comp_2 => Make_Component,
                 Comp_3 => Make_Component).Comp_3.Data
         is
            when 0 =>
               Put_Line ("ERROR: Test 9: Bomb not raised");
            when others =>
               Put_Line ("ERROR: Test 9: Bomb not raised");
         end case;
      end;
   exception
      when Bomb     => null;
      when Not_Zero => Put_Line ("ERROR: Test 9: Not_Zero raised");
      when others   => Put_Line ("ERROR: Test 9: unexpected exception");
   end;
   Put_Line ("Test 9 end");
end Aggregates;

----------------------------
-- Compilation and output --
----------------------------

$ gnatmake -q aggregates.adb
$ ./aggregates
Test 4
  ini comp 1
  ini comp 2
  ini comp 3
  ini comp 4
  ini comp 5
  adj comp 5 -> 500
  fin comp 5
  ini comp 6
  adj comp 6 -> 600
  fin comp 6
  fin comp 600
  fin comp 500
  fin enca 4
  fin comp 3
  fin comp 2
  fin comp 1
Test 4 end
Test 5
  ini comp 7
  adj comp 7 -> 700
  fin comp 7
  fin comp 700
Test 5 end
Test 6
  ini comp 8
  ini comp 9
  ini comp 10
  ini comp 11
  ini comp 12
  adj comp 12 -> 1200
  fin comp 12
  fin comp 1200
  fin enca 11
  fin comp 10
  fin comp 9
  fin comp 8
Test 6 end
Test 7
  ini comp 13
  ini comp 14
  ini comp 15
  ini comp 16
  ini comp 17
  adj comp 17 -> 1700
  fin comp 17
  ini comp 18
  adj comp 18 -> 1800
  fin comp 18
  fin comp 1800
  fin comp 1700
  fin enca 16
  fin comp 15
  fin comp 14
  fin comp 13
Test 7 end
Test 8
  ini comp 30
  adj comp 30 -> 3000
  fin comp 30
  fin comp 3000
Test 8 end
Test 9
  ini comp 31
  adj comp 31 -> 3100
  fin comp 31
  ini comp 32
  adj comp 32 -> 3200
  fin comp 32
  fin comp 3200
  fin comp 3100
Test 9 end

Tested on x86_64-pc-linux-gnu, committed on trunk

2014-02-06  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch4.adb (Process_Transient_Object): Add local variable
	Temp_Ins. When the transient object is initialized by an
	aggregate, the hook must capture the object after the last
	component assignment takes place.
	* exp_ch7.adb (Detect_Subprogram_Call): Expose the subprogram to
	routine Is_Subprogram_Call.
	(Is_Subprogram_Call): Inspect an
	aggregate that has been heavily expanded for subprogram calls.
	(Process_Transient_Objects): Add local variables Expr, Ptr_Id
	and Temp_Ins.  Remove the nested declare block and adjust the
	indentation. When the transient object is initialized by an
	aggregate, the hook must capture the object after the last
	component assignment takes place.
diff mbox

Patch

Index: exp_ch7.adb
===================================================================
--- exp_ch7.adb	(revision 207533)
+++ exp_ch7.adb	(working copy)
@@ -2454,12 +2454,23 @@ 
              Expression => Make_Integer_Literal (Loc, Counter_Val));
 
          --  Insert the counter after all initialization has been done. The
-         --  place of insertion depends on the context. When dealing with a
-         --  controlled function, the counter is inserted directly after the
-         --  declaration because such objects lack init calls.
+         --  place of insertion depends on the context. If an object is being
+         --  initialized via an aggregate, then the counter must be inserted
+         --  after the last aggregate assignment.
 
-         Find_Last_Init (Decl, Obj_Typ, Count_Ins, Body_Ins);
+         if Ekind (Obj_Id) = E_Variable
+           and then Present (Last_Aggregate_Assignment (Obj_Id))
+         then
+            Count_Ins := Last_Aggregate_Assignment (Obj_Id);
+            Body_Ins  := Empty;
 
+         --  In all other cases the counter is inserted after the last call to
+         --  either [Deep_]Initialize or the type specific init proc.
+
+         else
+            Find_Last_Init (Decl, Obj_Typ, Count_Ins, Body_Ins);
+         end if;
+
          Insert_After (Count_Ins, Inc_Decl);
          Analyze (Inc_Decl);
 
@@ -4419,17 +4430,25 @@ 
          function Is_Subprogram_Call (N : Node_Id) return Traverse_Result;
          --  Determine whether an arbitrary node denotes a subprogram call
 
+         procedure Detect_Subprogram_Call is
+           new Traverse_Proc (Is_Subprogram_Call);
+
          ------------------------
          -- Is_Subprogram_Call --
          ------------------------
 
          function Is_Subprogram_Call (N : Node_Id) return Traverse_Result is
          begin
-            --  A regular procedure or function call
+            --  Aggregates are usually rewritten into component by component
+            --  assignments and replaced by a reference to a temporary in the
+            --  original tree. Peek in the aggregate to detect function calls.
 
-            if Nkind (N) in N_Subprogram_Call then
-               Must_Hook := True;
-               return Abandon;
+            if Nkind (N) = N_Identifier
+              and then Nkind_In (Original_Node (N), N_Aggregate,
+                                                    N_Extension_Aggregate)
+            then
+               Detect_Subprogram_Call (Original_Node (N));
+               return OK;
 
             --  Detect a call to a function that returns on the secondary stack
 
@@ -4439,6 +4458,12 @@ 
                Must_Hook := True;
                return Abandon;
 
+            --  A regular procedure or function call
+
+            elsif Nkind (N) in N_Subprogram_Call then
+               Must_Hook := True;
+               return Abandon;
+
             --  Keep searching
 
             else
@@ -4446,13 +4471,11 @@ 
             end if;
          end Is_Subprogram_Call;
 
-         procedure Detect_Subprogram_Call is
-           new Traverse_Proc (Is_Subprogram_Call);
-
          --  Local variables
 
          Built     : Boolean := False;
          Desig_Typ : Entity_Id;
+         Expr      : Node_Id;
          Fin_Block : Node_Id;
          Fin_Data  : Finalization_Exception_Data;
          Fin_Decls : List_Id;
@@ -4462,9 +4485,11 @@ 
          Obj_Ref   : Node_Id;
          Obj_Typ   : Entity_Id;
          Prev_Fin  : Node_Id := Empty;
+         Ptr_Id    : Entity_Id;
          Stmt      : Node_Id;
          Stmts     : List_Id;
          Temp_Id   : Entity_Id;
+         Temp_Ins  : Node_Id;
 
       --  Start of processing for Process_Transient_Objects
 
@@ -4505,11 +4530,10 @@ 
                --  time around.
 
                if not Built then
+                  Built     := True;
                   Fin_Decls := New_List;
 
                   Build_Object_Declarations (Fin_Data, Fin_Decls, Loc);
-
-                  Built := True;
                end if;
 
                --  Transient variables associated with subprogram calls need
@@ -4524,69 +4548,80 @@ 
                --  "hooks" are picked up by the finalization machinery.
 
                if Must_Hook then
-                  declare
-                     Expr   : Node_Id;
-                     Ptr_Id : Entity_Id;
 
-                  begin
-                     --  Step 1: Create an access type which provides a
-                     --  reference to the transient object. Generate:
+                  --  Step 1: Create an access type which provides a reference
+                  --  to the transient object. Generate:
 
-                     --    Ann : access [all] <Desig_Typ>;
+                  --    Ann : access [all] <Desig_Typ>;
 
-                     Ptr_Id := Make_Temporary (Loc, 'A');
+                  Ptr_Id := Make_Temporary (Loc, 'A');
 
-                     Insert_Action (Stmt,
-                       Make_Full_Type_Declaration (Loc,
-                         Defining_Identifier => Ptr_Id,
-                         Type_Definition     =>
-                           Make_Access_To_Object_Definition (Loc,
-                             All_Present        =>
-                               Ekind (Obj_Typ) = E_General_Access_Type,
-                             Subtype_Indication =>
-                               New_Reference_To (Desig_Typ, Loc))));
+                  Insert_Action (Stmt,
+                    Make_Full_Type_Declaration (Loc,
+                      Defining_Identifier => Ptr_Id,
+                      Type_Definition     =>
+                        Make_Access_To_Object_Definition (Loc,
+                          All_Present        =>
+                            Ekind (Obj_Typ) = E_General_Access_Type,
+                          Subtype_Indication =>
+                            New_Reference_To (Desig_Typ, Loc))));
 
-                     --  Step 2: Create a temporary which acts as a hook to
-                     --  the transient object. Generate:
+                  --  Step 2: Create a temporary which acts as a hook to the
+                  --  transient object. Generate:
 
-                     --    Temp : Ptr_Id := null;
+                  --    Temp : Ptr_Id := null;
 
-                     Temp_Id := Make_Temporary (Loc, 'T');
+                  Temp_Id := Make_Temporary (Loc, 'T');
 
-                     Insert_Action (Stmt,
-                       Make_Object_Declaration (Loc,
-                         Defining_Identifier => Temp_Id,
-                         Object_Definition   =>
-                           New_Reference_To (Ptr_Id, Loc)));
+                  Insert_Action (Stmt,
+                    Make_Object_Declaration (Loc,
+                      Defining_Identifier => Temp_Id,
+                      Object_Definition   =>
+                        New_Reference_To (Ptr_Id, Loc)));
 
-                     --  Mark the temporary as a transient hook. This signals
-                     --  the machinery in Build_Finalizer to recognize this
-                     --  special case.
+                  --  Mark the temporary as a transient hook. This signals the
+                  --  machinery in Build_Finalizer to recognize this special
+                  --  case.
 
-                     Set_Status_Flag_Or_Transient_Decl (Temp_Id, Stmt);
+                  Set_Status_Flag_Or_Transient_Decl (Temp_Id, Stmt);
 
-                     --  Step 3: Hook the transient object to the temporary
+                  --  Step 3: Hook the transient object to the temporary
 
-                     if Is_Access_Type (Obj_Typ) then
-                        Expr :=
-                          Convert_To (Ptr_Id, New_Reference_To (Obj_Id, Loc));
-                     else
-                        Expr :=
-                          Make_Attribute_Reference (Loc,
-                            Prefix         => New_Reference_To (Obj_Id, Loc),
-                            Attribute_Name => Name_Unrestricted_Access);
-                     end if;
+                  if Is_Access_Type (Obj_Typ) then
+                     Expr :=
+                       Convert_To (Ptr_Id, New_Reference_To (Obj_Id, Loc));
+                  else
+                     Expr :=
+                       Make_Attribute_Reference (Loc,
+                         Prefix         => New_Reference_To (Obj_Id, Loc),
+                         Attribute_Name => Name_Unrestricted_Access);
+                  end if;
 
-                     --  Generate:
-                     --    Temp := Ptr_Id (Obj_Id);
-                     --      <or>
-                     --    Temp := Obj_Id'Unrestricted_Access;
+                  --  Generate:
+                  --    Temp := Ptr_Id (Obj_Id);
+                  --      <or>
+                  --    Temp := Obj_Id'Unrestricted_Access;
 
-                     Insert_After_And_Analyze (Stmt,
-                       Make_Assignment_Statement (Loc,
-                         Name       => New_Reference_To (Temp_Id, Loc),
-                         Expression => Expr));
-                  end;
+                  --  When the transient object is initialized by an aggregate,
+                  --  the hook must capture the object after the last component
+                  --  assignment takes place. Only then is the object fully
+                  --  initialized.
+
+                  if Ekind (Obj_Id) = E_Variable
+                    and then Present (Last_Aggregate_Assignment (Obj_Id))
+                  then
+                     Temp_Ins := Last_Aggregate_Assignment (Obj_Id);
+
+                  --  Otherwise the hook seizes the related object immediately
+
+                  else
+                     Temp_Ins := Stmt;
+                  end if;
+
+                  Insert_After_And_Analyze (Temp_Ins,
+                    Make_Assignment_Statement (Loc,
+                      Name       => New_Reference_To (Temp_Id, Loc),
+                      Expression => Expr));
                end if;
 
                Stmts := New_List;
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb	(revision 207533)
+++ exp_ch4.adb	(working copy)
@@ -12386,6 +12386,7 @@ 
       Fin_Stmts : List_Id;
       Ptr_Id    : Entity_Id;
       Temp_Id   : Entity_Id;
+      Temp_Ins  : Node_Id;
 
    --  Start of processing for Process_Transient_Object
 
@@ -12463,7 +12464,22 @@ 
       --      <or>
       --    Temp := Obj_Id'Unrestricted_Access;
 
-      Insert_After_And_Analyze (Decl,
+      --  When the transient object is initialized by an aggregate, the hook
+      --  must capture the object after the last component assignment takes
+      --  place. Only then is the object fully initialized.
+
+      if Ekind (Obj_Id) = E_Variable
+        and then Present (Last_Aggregate_Assignment (Obj_Id))
+      then
+         Temp_Ins := Last_Aggregate_Assignment (Obj_Id);
+
+      --  Otherwise the hook seizes the related object immediately
+
+      else
+         Temp_Ins := Decl;
+      end if;
+
+      Insert_After_And_Analyze (Temp_Ins,
         Make_Assignment_Statement (Loc,
           Name       => New_Reference_To (Temp_Id, Loc),
           Expression => Expr));