Patchwork [Ada] Missing finalization of temporary function results in case and if

login
register
mail settings
Submitter Arnaud Charlet
Date Feb. 6, 2013, 10:11 a.m.
Message ID <20130206101128.GA29602@adacore.com>
Download mbox | patch
Permalink /patch/218525/
State New
Headers show

Comments

Arnaud Charlet - Feb. 6, 2013, 10:11 a.m.
This patch adds machinery to properly finalize temporary controlled function
results that appear in N_Expression_With_Actions nodes as well as case and if
expressions. In general, such temporaries must be finalized after the related
context is elaborated/evaluated.

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

--  types.ads

with Ada.Finalization; use Ada.Finalization;
package Types is
   type Ctrl is new Controlled with record
      Data : Natural := 1234;
   end record;

   procedure Finalize (Obj : in out Ctrl);
   function Make_Ctrl (Val : Natural) return Ctrl;
end Types;

--  types.adb

with Ada.Text_IO; use Ada.Text_IO;

package body Types is
   procedure Finalize (Obj : in out Ctrl) is
   begin
      Obj.Data := 0;
      Put_Line ("   fin");
   end Finalize;

   function Make_Ctrl (Val : Natural) return Ctrl is
   begin
      return (Controlled with Val);
   end Make_Ctrl;
end Types;

--  main.adb

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

procedure Main is
   procedure Ensure_Value (Val : Natural; Exp : Natural; Act : Natural) is
   begin
      if Val /= Exp then
         Put_Line ("ERROR: transient finalized too early");
         Put_Line ("  Expected:" & Exp'Img);
         Put_Line ("  Got     :" & Act'Img);
      end if;
   end Ensure_Value;

   function Factorial (Val : Natural) return Natural is
   begin
      if Val > 1 then
         return Factorial (Val - 1) * Val;
      else
         return 1;
      end if;
   end Factorial;

   Exp  : constant Natural := 9876;
   Junk : constant Natural := 5432;
   Flag : Boolean;
   Val  : Natural;

begin
   Put_Line ("Case expression");
   Val := (case Factorial (3) is
              when 6      => Make_Ctrl (Exp).Data,
              when others => Junk);
   Ensure_Value (Val, Exp, Junk);

   Put_Line ("If expression");
   Val := (if Factorial (3) = 6 then
              Make_Ctrl (Exp).Data
           else
              Junk);
   Ensure_Value (Val, Exp, Junk);

   Put_Line ("If statement");
   if Val = Exp
     and then Make_Ctrl (Exp).Data = Exp
   then
      Put_Line ("      then statements");
   end if;

   Put_Line ("Assignment");
   Flag := Val = Exp and then Make_Ctrl (Exp).Data = Exp;

   Put_Line ("End");
end Main;

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

$ gnatmake -q -gnat12 main.adb
$ ./main
Case expression
   fin
   fin
If expression
   fin
   fin
If statement
   fin
   fin
      then statements
Assignment
   fin
   fin
End

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

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

	* exp_ch4.adb (Expand_N_Expression_With_Actions): Rewritten. This
	routine should be able to properly detect controlled transient
	objects in its actions and generate the appropriate finalization
	actions.
	* exp_ch6.adb (Enclosing_Context): Removed.
	(Expand_Ctrl_Function_Call): Remove local subprogram and
	constant. Use routine Within_Case_Or_If_Expression to determine
	whether the lifetime of the function result must be extended to
	match that of the context.
	* exp_util.ads, exp_util.adb (Within_Case_Or_If_Expression): New
	routine.

Patch

Index: exp_util.adb
===================================================================
--- exp_util.adb	(revision 195784)
+++ exp_util.adb	(working copy)
@@ -7944,6 +7944,43 @@ 
       end if;
    end Type_May_Have_Bit_Aligned_Components;
 
+   ----------------------------------
+   -- Within_Case_Or_If_Expression --
+   ----------------------------------
+
+   function Within_Case_Or_If_Expression (N : Node_Id) return Boolean is
+      Par : Node_Id;
+
+   begin
+      --  Locate an enclosing case or if expression. Note that these constructs
+      --  appear as expression_with_actions, hence the test using the original
+      --  node.
+
+      Par := N;
+      while Present (Par) loop
+         if Nkind_In (Original_Node (Par), N_Case_Expression,
+                                           N_If_Expression)
+         then
+            return True;
+
+         --  Prevent the search from going too far
+
+         elsif Nkind_In (Par, N_Entry_Body,
+                              N_Package_Body,
+                              N_Package_Declaration,
+                              N_Protected_Body,
+                              N_Subprogram_Body,
+                              N_Task_Body)
+         then
+            return False;
+         end if;
+
+         Par := Parent (Par);
+      end loop;
+
+      return False;
+   end Within_Case_Or_If_Expression;
+
    ----------------------------
    -- Wrap_Cleanup_Procedure --
    ----------------------------
Index: exp_util.ads
===================================================================
--- exp_util.ads	(revision 195784)
+++ exp_util.ads	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2013, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -818,6 +818,9 @@ 
    --  is conservative, in that a result of False is decisive. A result of True
    --  means that such a component may or may not be present.
 
+   function Within_Case_Or_If_Expression (N : Node_Id) return Boolean;
+   --  Determine whether arbitrary node N is within a case or an if expression
+
    procedure Wrap_Cleanup_Procedure (N : Node_Id);
    --  Given an N_Subprogram_Body node, this procedure adds an Abort_Defer call
    --  at the start of the statement sequence, and an Abort_Undefer call at the
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb	(revision 195784)
+++ exp_ch4.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2013, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -4984,145 +4984,317 @@ 
    --------------------------------------
 
    procedure Expand_N_Expression_With_Actions (N : Node_Id) is
+      In_Case_Or_If_Expression : constant Boolean :=
+                                   Within_Case_Or_If_Expression (N);
 
-      procedure Process_Transient_Object (Decl : Node_Id);
-      --  Given the declaration of a controlled transient declared inside the
-      --  Actions list of an Expression_With_Actions, generate all necessary
-      --  types and hooks in order to properly finalize the transient. This
-      --  mechanism works in conjunction with Build_Finalizer.
+      function Process_Action (Act : Node_Id) return Traverse_Result;
+      --  Inspect and process a single action of an expression_with_actions
 
-      ------------------------------
-      -- Process_Transient_Object --
-      ------------------------------
+      --------------------
+      -- Process_Action --
+      --------------------
 
-      procedure Process_Transient_Object (Decl : Node_Id) is
+      function Process_Action (Act : Node_Id) return Traverse_Result is
+         procedure Process_Transient_Object (Obj_Decl : Node_Id);
+         --  Obj_Decl denotes the declaration of a transient controlled object.
+         --  Generate all necessary types and hooks to properly finalize the
+         --  result when the enclosing context is elaborated/evaluated.
 
-         function Find_Insertion_Node return Node_Id;
-         --  Complex conditions in if statements may be converted into nested
-         --  EWAs. In this case, any generated code must be inserted before the
-         --  if statement to ensure proper visibility of the hook objects. This
-         --  routine returns the top most short circuit operator or the parent
-         --  of the EWA if no nesting was detected.
+         ------------------------------
+         -- Process_Transient_Object --
+         ------------------------------
 
-         -------------------------
-         -- Find_Insertion_Node --
-         -------------------------
+         procedure Process_Transient_Object (Obj_Decl : Node_Id) is
+            function Find_Enclosing_Context return Node_Id;
+            --  Find the context where the expression_with_actions appears
 
-         function Find_Insertion_Node return Node_Id is
-            Par : Node_Id;
+            ----------------------------
+            -- Find_Enclosing_Context --
+            ----------------------------
 
+            function Find_Enclosing_Context return Node_Id is
+               function Is_Body_Or_Unit (N : Node_Id) return Boolean;
+               --  Determine whether N denotes a body or unit declaration
+
+               ---------------------
+               -- Is_Body_Or_Unit --
+               ---------------------
+
+               function Is_Body_Or_Unit (N : Node_Id) return Boolean is
+               begin
+                  return Nkind_In (N, N_Entry_Body,
+                                      N_Package_Body,
+                                      N_Package_Declaration,
+                                      N_Protected_Body,
+                                      N_Subprogram_Body,
+                                      N_Task_Body);
+               end Is_Body_Or_Unit;
+
+               --  Local variables
+
+               Par : Node_Id;
+               Top : Node_Id;
+
+            --  Start of processing for Find_Enclosing_Context
+
+            begin
+               --  The expression_with_action is in a case or if expression and
+               --  the lifetime of any temporary controlled object is therefore
+               --  extended. Find a suitable insertion node by locating the top
+               --  most case or if expressions.
+
+               if In_Case_Or_If_Expression then
+                  Par := N;
+                  Top := N;
+                  while Present (Par) loop
+                     if Nkind_In (Original_Node (Par), N_Case_Expression,
+                                                       N_If_Expression)
+                     then
+                        Top := Par;
+
+                     --  Prevent the search from going too far
+
+                     elsif Is_Body_Or_Unit (Par) then
+                        exit;
+                     end if;
+
+                     Par := Parent (Par);
+                  end loop;
+
+                  --  The topmost case or if expression is now recovered, but
+                  --  it may still not be the correct place to add all the
+                  --  generated code. Climb to find a parent that is part of a
+                  --  declarative or statement list.
+
+                  Par := Top;
+                  while Present (Par) loop
+                     if Is_List_Member (Par)
+                       and then
+                          not Nkind_In (Par, N_Component_Association,
+                                             N_Discriminant_Association,
+                                             N_Parameter_Association,
+                                             N_Pragma_Argument_Association)
+                     then
+                        return Par;
+
+                     --  Prevent the search from going too far
+
+                     elsif Is_Body_Or_Unit (Par) then
+                        exit;
+                     end if;
+
+                     Par := Parent (Par);
+                  end loop;
+
+                  return Par;
+
+               --  Shor circuit operators in complex expressions are converted
+               --  into expression_with_actions.
+
+               else
+                  --  Take care of the case where the expression_with_actions
+                  --  is burried deep inside an if statement. The temporary
+                  --  function result must be finalized before the then, elsif
+                  --  or else statements are evaluated.
+
+                  --    if Something
+                  --      and then Ctrl_Func_Call
+                  --    then
+                  --       <result must be finalized at this point>
+                  --       <statements>
+                  --    end if;
+
+                  --  To achieve this, find the topmost logical operator. The
+                  --  generated actions are then inserted before/after it.
+
+                  Par := N;
+                  while Present (Par) loop
+
+                     --  Keep climbing past various operators
+
+                     if Nkind (Parent (Par)) in N_Op
+                       or else Nkind_In (Parent (Par), N_And_Then, N_Or_Else)
+                     then
+                        Par := Parent (Par);
+                     else
+                        exit;
+                     end if;
+                  end loop;
+
+                  Top := Par;
+
+                  --  The expression_with_action might be located in a pragm
+                  --  in which case locate the pragma itself:
+
+                  --    pragma Precondition (... and then Ctrl_Func_Call ...);
+
+                  --  Similar case occurs when the expression_with_actions is
+                  --  related to an object declaration or assignment:
+
+                  --    Obj [: Some_Typ] := ... and then Ctrl_Func_Call ...;
+
+                  while Present (Par) loop
+                     if Nkind_In (Par, N_Assignment_Statement,
+                                       N_Object_Declaration,
+                                       N_Pragma)
+                     then
+                        return Par;
+
+                     elsif Is_Body_Or_Unit (Par) then
+                        exit;
+                     end if;
+
+                     Par := Parent (Par);
+                  end loop;
+
+                  --  Return the topmost short circuit operator
+
+                  return Top;
+               end if;
+            end Find_Enclosing_Context;
+
+            --  Local variables
+
+            Context   : constant Node_Id    := Find_Enclosing_Context;
+            Loc       : constant Source_Ptr := Sloc (Obj_Decl);
+            Obj_Id    : constant Entity_Id  := Defining_Identifier (Obj_Decl);
+            Obj_Typ   : constant Node_Id    := Etype (Obj_Id);
+            Desig_Typ : Entity_Id;
+            Expr      : Node_Id;
+            Ptr_Id    : Entity_Id;
+            Temp_Id   : Entity_Id;
+
+         --  Start of processing for Process_Transient_Object
+
          begin
-            --  Climb up the branches of a complex condition
+            --  Step 1: Create the access type which provides a reference to
+            --  the transient object.
 
-            Par := N;
-            while Nkind_In (Parent (Par), N_And_Then, N_Op_Not, N_Or_Else) loop
-               Par := Parent (Par);
-            end loop;
+            if Is_Access_Type (Obj_Typ) then
+               Desig_Typ := Directly_Designated_Type (Obj_Typ);
+            else
+               Desig_Typ := Obj_Typ;
+            end if;
 
-            return Par;
-         end Find_Insertion_Node;
+            --  Generate:
+            --    Ann : access [all] <Desig_Typ>;
 
-         --  Local variables
+            Ptr_Id := Make_Temporary (Loc, 'A');
 
-         Ins_Node  : constant Node_Id    := Find_Insertion_Node;
-         Loc       : constant Source_Ptr := Sloc (Decl);
-         Obj_Id    : constant Entity_Id  := Defining_Identifier (Decl);
-         Obj_Typ   : constant Entity_Id  := Etype (Obj_Id);
-         Desig_Typ : Entity_Id;
-         Expr      : Node_Id;
-         Ptr_Decl  : Node_Id;
-         Ptr_Id    : Entity_Id;
-         Temp_Decl : Node_Id;
-         Temp_Id   : Node_Id;
+            Insert_Action (Context,
+              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))));
 
-      --  Start of processing for Process_Transient_Object
+            --  Step 2: Create a temporary which acts as a hook to the
+            --  transient object. Generate:
 
-      begin
-         --  Step 1: Create the access type which provides a reference to the
-         --  transient object.
+            --    Temp : Ptr_Id := null;
 
-         if Is_Access_Type (Obj_Typ) then
-            Desig_Typ := Directly_Designated_Type (Obj_Typ);
-         else
-            Desig_Typ := Obj_Typ;
-         end if;
+            Temp_Id := Make_Temporary (Loc, 'T');
 
-         --  Generate:
-         --    Ann : access [all] <Desig_Typ>;
+            Insert_Action (Context,
+              Make_Object_Declaration (Loc,
+                Defining_Identifier => Temp_Id,
+                Object_Definition   => New_Reference_To (Ptr_Id, Loc)));
 
-         Ptr_Id := Make_Temporary (Loc, 'A');
+            --  Mark this temporary as created for the purposes of exporting
+            --  the transient declaration out of the Actions list. This signals
+            --  the machinery in Build_Finalizer to recognize this special
+            --  case.
 
-         Ptr_Decl :=
-           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)));
+            Set_Status_Flag_Or_Transient_Decl (Temp_Id, Obj_Decl);
 
-         Insert_Action (Ins_Node, Ptr_Decl);
-         Analyze (Ptr_Decl);
+            --  Step 3: Hook the transient object to the temporary
 
-         --  Step 2: Create a temporary which acts as a hook to the transient
-         --  object. Generate:
+            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;
 
-         --    Temp : Ptr_Id := null;
+            --  Generate:
+            --    Temp := Ptr_Id (Obj_Id);
+            --      <or>
+            --    Temp := Obj_Id'Unrestricted_Access;
 
-         Temp_Id := Make_Temporary (Loc, 'T');
+            Insert_After_And_Analyze (Obj_Decl,
+              Make_Assignment_Statement (Loc,
+                Name       => New_Reference_To (Temp_Id, Loc),
+                Expression => Expr));
 
-         Temp_Decl :=
-           Make_Object_Declaration (Loc,
-             Defining_Identifier => Temp_Id,
-             Object_Definition   => New_Reference_To (Ptr_Id, Loc));
+            --  Step 4: Finalize the function result after the context has been
+            --  evaluated/elaborated. Generate:
 
-         Insert_Action (Ins_Node, Temp_Decl);
-         Analyze (Temp_Decl);
+            --    if Temp /= null then
+            --       [Deep_]Finalize (Temp.all);
+            --       Temp := null;
+            --    end if;
 
-         --  Mark this temporary as created for the purposes of exporting the
-         --  transient declaration out of the Actions list. This signals the
-         --  machinery in Build_Finalizer to recognize this special case.
+            Insert_Action_After (Context,
+              Make_If_Statement (Loc,
+                Condition =>
+                  Make_Op_Ne (Loc,
+                    Left_Opnd  => New_Reference_To (Temp_Id, Loc),
+                    Right_Opnd => Make_Null (Loc)),
 
-         Set_Status_Flag_Or_Transient_Decl (Temp_Id, Decl);
+                Then_Statements => New_List (
+                  Make_Final_Call
+                    (Obj_Ref =>
+                       Make_Explicit_Dereference (Loc,
+                         Prefix => New_Reference_To (Temp_Id, Loc)),
+                     Typ     => Desig_Typ),
 
-         --  Step 3: Hook the transient object to the temporary
+                  Make_Assignment_Statement (Loc,
+                    Name       => New_Reference_To (Temp_Id, Loc),
+                    Expression => Make_Null (Loc)))));
+         end Process_Transient_Object;
 
-         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);
+      --  Start of processing for Process_Action
+
+      begin
+         if Nkind (Act) = N_Object_Declaration
+           and then Is_Finalizable_Transient (Act, N)
+         then
+            Process_Transient_Object (Act);
+
+         --  Avoid processing temporary function results multiple times when
+         --  dealing with nested expression_with_actions.
+
+         elsif Nkind (Act) = N_Expression_With_Actions then
+            return Abandon;
+
+         --  Do not process temporary function results in loops. This is
+         --  done by Expand_N_Loop_Statement and Build_Finalizer.
+
+         elsif Nkind (Act) = N_Loop_Statement then
+            return Abandon;
          end if;
 
-         --  Generate:
-         --    Temp := Ptr_Id (Obj_Id);
-         --      <or>
-         --    Temp := Obj_Id'Unrestricted_Access;
+         return OK;
+      end Process_Action;
 
-         Insert_After_And_Analyze (Decl,
-           Make_Assignment_Statement (Loc,
-             Name       => New_Reference_To (Temp_Id, Loc),
-             Expression => Expr));
-      end Process_Transient_Object;
+      procedure Process_Single_Action is new Traverse_Proc (Process_Action);
 
       --  Local variables
 
-      Decl : Node_Id;
+      Act : Node_Id;
 
    --  Start of processing for Expand_N_Expression_With_Actions
 
    begin
-      Decl := First (Actions (N));
-      while Present (Decl) loop
-         if Nkind (Decl) = N_Object_Declaration
-           and then Is_Finalizable_Transient (Decl, N)
-         then
-            Process_Transient_Object (Decl);
-         end if;
+      Act := First (Actions (N));
+      while Present (Act) loop
+         Process_Single_Action (Act);
 
-         Next (Decl);
+         Next (Act);
       end loop;
    end Expand_N_Expression_With_Actions;
 
Index: exp_ch6.adb
===================================================================
--- exp_ch6.adb	(revision 195784)
+++ exp_ch6.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2013, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -4036,45 +4036,6 @@ 
    -------------------------------
 
    procedure Expand_Ctrl_Function_Call (N : Node_Id) is
-      function Enclosing_Context return Node_Id;
-      --  Find the enclosing context where the function call appears
-
-      -----------------------
-      -- Enclosing_Context --
-      -----------------------
-
-      function Enclosing_Context return Node_Id is
-         Context : Node_Id;
-
-      begin
-         Context := Parent (N);
-         while Present (Context) loop
-
-            --  The following could use a comment (and why is N_Case_Expression
-            --  not treated in a similar manner ???
-
-            if Nkind (Context) = N_If_Expression then
-               exit;
-
-            --  Stop the search when reaching any statement because we have
-            --  gone too far up the tree.
-
-            elsif Nkind (Context) = N_Procedure_Call_Statement
-              or else Nkind (Context) in N_Statement_Other_Than_Procedure_Call
-            then
-               exit;
-            end if;
-
-            Context := Parent (Context);
-         end loop;
-
-         return Context;
-      end Enclosing_Context;
-
-      --  Local variables
-
-      Context : constant Node_Id := Enclosing_Context;
-
    begin
       --  Optimization, if the returned value (which is on the sec-stack) is
       --  returned again, no need to copy/readjust/finalize, we can just pass
@@ -4096,15 +4057,12 @@ 
 
       Remove_Side_Effects (N);
 
-      --  The function call is part of an if expression dependent expression.
-      --  The temporary result must live as long as the if expression itself,
-      --  otherwise it will be finalized too early. Mark the transient as
-      --  processed to avoid untimely finalization.
+      --  When the temporary function result appears inside a case or an if
+      --  expression, its lifetime must be extended to match that of the
+      --  context. If not, the function result would be finalized prematurely
+      --  and the evaluation of the expression could yield the wrong result.
 
-      --  Why no special handling for case expressions here ???
-
-      if Present (Context)
-        and then Nkind (Context) = N_If_Expression
+      if Within_Case_Or_If_Expression (N)
         and then Nkind (N) = N_Explicit_Dereference
       then
          Set_Is_Processed_Transient (Entity (Prefix (N)));