diff mbox series

[Ada] Avoid secondary stack for nondispatching build-in-place calls

Message ID 20170907093356.GA75090@adacore.com
State New
Headers show
Series [Ada] Avoid secondary stack for nondispatching build-in-place calls | expand

Commit Message

Arnaud Charlet Sept. 7, 2017, 9:33 a.m. UTC
This patch fixes a performance regression. The compiler was using the
secondary stack for a nondispatching build-in-place call, which is
unnecessary, and indeed older compilers did not do so. The compiler no
longer uses the secondary stack for such calls. Note that the secondary
stack is necessary for dispatching calls, because the caller doesn't
know the size of the result. The older compilers mentioned above did not
do that, which was a bug. Fixing that bug caused the performance
regression. No change in behavior; no test available.

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

2017-09-07  Bob Duff  <duff@adacore.com>

	* exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration,
	Make_Build_In_Place_Call_In_Anonymous_Context): Do not use the
	secondary stack for all functions that return limited tagged
	types -- just do it for dispatching calls.  Misc cleanup.
	* sem_util.ads, sem_util.adb (Unqual_Conv): New function to
	remove qualifications and type conversions. Fix various bugs
	where only a single level of qualification or conversion was
	removed, so e.g. "T1'(T2'(X))" would incorrectly return "T2'(X)"
	instead of "X".
	* checks.adb, exp_util.ads, exp_util.adb, sem_res.adb: Misc related
	cleanup.
diff mbox series

Patch

Index: exp_util.adb
===================================================================
--- exp_util.adb	(revision 251786)
+++ exp_util.adb	(working copy)
@@ -8274,79 +8274,6 @@ 
           and then not Is_Build_In_Place_Function_Call (Prefix (Expr));
    end Is_Non_BIP_Func_Call;
 
-   ------------------------------------
-   -- Is_Object_Access_BIP_Func_Call --
-   ------------------------------------
-
-   function Is_Object_Access_BIP_Func_Call
-      (Expr   : Node_Id;
-       Obj_Id : Entity_Id) return Boolean
-   is
-      Access_Nam : Name_Id := No_Name;
-      Actual     : Node_Id;
-      Call       : Node_Id;
-      Formal     : Node_Id;
-      Param      : Node_Id;
-
-   begin
-      --  Build-in-place calls usually appear in 'reference format. Note that
-      --  the accessibility check machinery may add an extra 'reference due to
-      --  side effect removal.
-
-      Call := Expr;
-      while Nkind (Call) = N_Reference loop
-         Call := Prefix (Call);
-      end loop;
-
-      if Nkind_In (Call, N_Qualified_Expression,
-                         N_Unchecked_Type_Conversion)
-      then
-         Call := Expression (Call);
-      end if;
-
-      if Is_Build_In_Place_Function_Call (Call) then
-
-         --  Examine all parameter associations of the function call
-
-         Param := First (Parameter_Associations (Call));
-         while Present (Param) loop
-            if Nkind (Param) = N_Parameter_Association
-              and then Nkind (Selector_Name (Param)) = N_Identifier
-            then
-               Formal := Selector_Name (Param);
-               Actual := Explicit_Actual_Parameter (Param);
-
-               --  Construct the name of formal BIPaccess. It is much easier to
-               --  extract the name of the function using an arbitrary formal's
-               --  scope rather than the Name field of Call.
-
-               if Access_Nam = No_Name and then Present (Entity (Formal)) then
-                  Access_Nam :=
-                    New_External_Name
-                      (Chars (Scope (Entity (Formal))),
-                       BIP_Formal_Suffix (BIP_Object_Access));
-               end if;
-
-               --  A match for BIPaccess => Obj_Id'Unrestricted_Access has been
-               --  found.
-
-               if Chars (Formal) = Access_Nam
-                 and then Nkind (Actual) = N_Attribute_Reference
-                 and then Attribute_Name (Actual) = Name_Unrestricted_Access
-                 and then Nkind (Prefix (Actual)) = N_Identifier
-                 and then Entity (Prefix (Actual)) = Obj_Id
-               then
-                  return True;
-               end if;
-            end if;
-
-            Next (Param);
-         end loop;
-      end if;
-
-      return False;
-   end Is_Object_Access_BIP_Func_Call;
-
    ----------------------------------
    -- Is_Possibly_Unaligned_Object --
    ----------------------------------
@@ -8739,11 +8666,7 @@ 
          Call := Prefix (Call);
       end loop;
 
-      if Nkind_In (Call, N_Qualified_Expression,
-                         N_Unchecked_Type_Conversion)
-      then
-         Call := Expression (Call);
-      end if;
+      Call := Unqual_Conv (Call);
 
       if Is_Build_In_Place_Function_Call (Call) then
 
Index: exp_util.ads
===================================================================
--- exp_util.ads	(revision 251753)
+++ exp_util.ads	(working copy)
@@ -774,12 +774,6 @@ 
    function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean;
    --  Determine whether node Expr denotes a non build-in-place function call
 
-   function Is_Object_Access_BIP_Func_Call
-      (Expr   : Node_Id;
-       Obj_Id : Entity_Id) return Boolean;
-   --  Determine if Expr denotes a build-in-place function which stores its
-   --  result in the BIPaccess actual parameter whose prefix must match Obj_Id.
-
    function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean;
    --  Node N is an object reference. This function returns True if it is
    --  possible that the object may not be aligned according to the normal
Index: sem_util.adb
===================================================================
--- sem_util.adb	(revision 251789)
+++ sem_util.adb	(working copy)
@@ -15734,22 +15734,10 @@ 
    --------------------------------------
 
    function Is_Validation_Variable_Reference (N : Node_Id) return Boolean is
-      Var    : Node_Id;
+      Var    : constant Node_Id := Unqual_Conv (N);
       Var_Id : Entity_Id;
 
    begin
-      Var := N;
-
-      --  Use the expression when the context qualifies a reference in some
-      --  fashion.
-
-      while Nkind_In (Var, N_Qualified_Expression,
-                           N_Type_Conversion,
-                           N_Unchecked_Type_Conversion)
-      loop
-         Var := Expression (Var);
-      end loop;
-
       Var_Id := Empty;
 
       if Is_Entity_Name (Var) then
@@ -22497,6 +22485,28 @@ 
       end if;
    end Unqualify;
 
+   -----------------
+   -- Unqual_Conv --
+   -----------------
+
+   function Unqual_Conv (Expr : Node_Id) return Node_Id is
+   begin
+      --  Recurse to handle unlikely case of multiple levels of qualification
+      --  and/or conversion.
+
+      if Nkind_In (Expr, N_Qualified_Expression,
+                         N_Type_Conversion,
+                         N_Unchecked_Type_Conversion)
+      then
+         return Unqual_Conv (Expression (Expr));
+
+      --  Normal case, not a qualified expression
+
+      else
+         return Expr;
+      end if;
+   end Unqual_Conv;
+
    -----------------------
    -- Visible_Ancestors --
    -----------------------
Index: sem_util.ads
===================================================================
--- sem_util.ads	(revision 251786)
+++ sem_util.ads	(working copy)
@@ -2571,6 +2571,11 @@ 
    --  Removes any qualifications from Expr. For example, for T1'(T2'(X)), this
    --  returns X. If Expr is not a qualified expression, returns Expr.
 
+   function Unqual_Conv (Expr : Node_Id) return Node_Id;
+   pragma Inline (Unqual_Conv);
+   --  Similar to Unqualify, but removes qualified expressions, type
+   --  conversions, and unchecked conversions.
+
    function Visible_Ancestors (Typ : Entity_Id) return Elist_Id;
    --  [Ada 2012:AI-0125-1]: Collect all the visible parents and progenitors
    --  of a type extension or private extension declaration. If the full-view
Index: exp_ch6.adb
===================================================================
--- exp_ch6.adb	(revision 251807)
+++ exp_ch6.adb	(working copy)
@@ -136,6 +136,14 @@ 
    --  the activation Chain. Note: Master_Actual can be Empty, but only if
    --  there are no tasks.
 
+   function Caller_Known_Size
+     (Func_Call : Node_Id; Result_Subt : Entity_Id) return Boolean;
+   --  True if result subtype is definite, or has a size that does not require
+   --  secondary stack usage (i.e. no variant part or components whose type
+   --  depends on discriminants). In particular, untagged types with only
+   --  access discriminants do not require secondary stack use. Note we must
+   --  always use the secondary stack for dispatching-on-result calls.
+
    procedure Check_Overriding_Operation (Subp : Entity_Id);
    --  Subp is a dispatching operation. Check whether it may override an
    --  inherited private operation, in which case its DT entry is that of
@@ -824,6 +832,18 @@ 
       return New_Body;
    end Build_Procedure_Body_Form;
 
+   -----------------------
+   -- Caller_Known_Size --
+   -----------------------
+
+   function Caller_Known_Size
+     (Func_Call : Node_Id; Result_Subt : Entity_Id) return Boolean is
+   begin
+      return (Is_Definite_Subtype (Underlying_Type (Result_Subt))
+              and then No (Controlling_Argument (Func_Call)))
+          or else not Requires_Transient_Scope (Underlying_Type (Result_Subt));
+   end Caller_Known_Size;
+
    --------------------------------
    -- Check_Overriding_Operation --
    --------------------------------
@@ -1631,22 +1651,10 @@ 
          Expr    : Node_Id;
          Obj     : Node_Id;
          Obj_Typ : Entity_Id;
-         Var     : Node_Id;
+         Var     : constant Node_Id := Unqual_Conv (Act);
          Var_Id  : Entity_Id;
 
       begin
-         Var := Act;
-
-         --  Use the expression when the context qualifies a reference in some
-         --  fashion.
-
-         while Nkind_In (Var, N_Qualified_Expression,
-                              N_Type_Conversion,
-                              N_Unchecked_Type_Conversion)
-         loop
-            Var := Expression (Var);
-         end loop;
-
          --  Copy the value of the validation variable back into the object
          --  being validated.
 
@@ -6796,12 +6804,7 @@ 
                Discrim_Source := Original_Node (Discrim_Source);
             end if;
 
-            while Nkind_In (Discrim_Source, N_Qualified_Expression,
-                                            N_Type_Conversion,
-                                            N_Unchecked_Type_Conversion)
-            loop
-               Discrim_Source := Expression (Discrim_Source);
-            end loop;
+            Discrim_Source := Unqual_Conv (Discrim_Source);
 
             case Nkind (Discrim_Source) is
                when N_Defining_Identifier =>
@@ -7099,7 +7102,7 @@ 
    -------------------------------------
 
    function Is_Build_In_Place_Function_Call (N : Node_Id) return Boolean is
-      Exp_Node    : Node_Id := N;
+      Exp_Node    : constant Node_Id := Unqual_Conv (N);
       Function_Id : Entity_Id;
 
    begin
@@ -7119,17 +7122,6 @@ 
          return False;
       end if;
 
-      --  Step past qualification, type conversion (which can occur in actual
-      --  parameter contexts), and unchecked conversion (which can occur in
-      --  cases of calls to 'Input).
-
-      if Nkind_In (Exp_Node, N_Qualified_Expression,
-                             N_Type_Conversion,
-                             N_Unchecked_Type_Conversion)
-      then
-         Exp_Node := Expression (N);
-      end if;
-
       if Nkind (Exp_Node) /= N_Function_Call then
          return False;
 
@@ -7771,32 +7763,13 @@ 
      (Function_Call : Node_Id)
    is
       Loc             : Source_Ptr;
-      Func_Call       : Node_Id := Function_Call;
+      Func_Call       : constant Node_Id := Unqual_Conv (Function_Call);
       Function_Id     : Entity_Id;
       Result_Subt     : Entity_Id;
       Return_Obj_Id   : Entity_Id;
       Return_Obj_Decl : Entity_Id;
 
-      Definite : Boolean;
-      --  True if result subtype is definite, or has a size that does not
-      --  require secondary stack usage (i.e. no variant part or components
-      --  whose type depends on discriminants). In particular, untagged types
-      --  with only access discriminants do not require secondary stack use.
-      --  Note that if the return type is tagged we must always use the sec.
-      --  stack because the call may dispatch on result.
-
    begin
-      --  Step past qualification, type conversion (which can occur in actual
-      --  parameter contexts), and unchecked conversion (which can occur in
-      --  cases of calls to 'Input).
-
-      if Nkind_In (Func_Call, N_Qualified_Expression,
-                              N_Type_Conversion,
-                              N_Unchecked_Type_Conversion)
-      then
-         Func_Call := Expression (Func_Call);
-      end if;
-
       --  If the call has already been processed to add build-in-place actuals
       --  then return. One place this can occur is for calls to build-in-place
       --  functions that occur within a call to a protected operation, where
@@ -7824,10 +7797,6 @@ 
       end if;
 
       Result_Subt := Etype (Function_Id);
-      Definite :=
-        (Is_Definite_Subtype (Underlying_Type (Result_Subt))
-             and then not Is_Tagged_Type (Result_Subt))
-          or else not Requires_Transient_Scope (Underlying_Type (Result_Subt));
 
       --  If the build-in-place function returns a controlled object, then the
       --  object needs to be finalized immediately after the context. Since
@@ -7869,7 +7838,7 @@ 
       --  When the result subtype is definite, an object of the subtype is
       --  declared and an access value designating it is passed as an actual.
 
-      elsif Definite then
+      elsif Caller_Known_Size (Func_Call, Result_Subt) then
 
          --  Create a temporary object to hold the function result
 
@@ -7942,7 +7911,7 @@ 
       Function_Call : Node_Id)
    is
       Lhs          : constant Node_Id := Name (Assign);
-      Func_Call    : Node_Id := Function_Call;
+      Func_Call    : constant Node_Id := Unqual_Conv (Function_Call);
       Func_Id      : Entity_Id;
       Loc          : Source_Ptr;
       Obj_Decl     : Node_Id;
@@ -7954,15 +7923,6 @@ 
       Target       : Node_Id;
 
    begin
-      --  Step past qualification or unchecked conversion (the latter can occur
-      --  in cases of calls to 'Input).
-
-      if Nkind_In (Func_Call, N_Qualified_Expression,
-                              N_Unchecked_Type_Conversion)
-      then
-         Func_Call := Expression (Func_Call);
-      end if;
-
       --  If the call has already been processed to add build-in-place actuals
       --  then return. This should not normally occur in an assignment context,
       --  but we add the protection as a defensive measure.
@@ -8085,7 +8045,7 @@ 
       Caller_Object   : Node_Id;
       Def_Id          : Entity_Id;
       Fmaster_Actual  : Node_Id := Empty;
-      Func_Call       : Node_Id := Function_Call;
+      Func_Call       : constant Node_Id := Unqual_Conv (Function_Call);
       Function_Id     : Entity_Id;
       Pool_Actual     : Node_Id;
       Ptr_Typ         : Entity_Id;
@@ -8094,24 +8054,7 @@ 
       Res_Decl        : Node_Id;
       Result_Subt     : Entity_Id;
 
-      Definite : Boolean;
-      --  True if result subtype is definite, or has a size that does not
-      --  require secondary stack usage (i.e. no variant part or components
-      --  whose type depends on discriminants). In particular, untagged types
-      --  with only access discriminants do not require secondary stack use.
-      --  Note that if the return type is tagged we must always use the sec.
-      --  stack because the call may dispatch on result.
-
    begin
-      --  Step past qualification or unchecked conversion (the latter can occur
-      --  in cases of calls to 'Input).
-
-      if Nkind_In (Func_Call, N_Qualified_Expression,
-                              N_Unchecked_Type_Conversion)
-      then
-         Func_Call := Expression (Func_Call);
-      end if;
-
       --  If the call has already been processed to add build-in-place actuals
       --  then return. This should not normally occur in an object declaration,
       --  but we add the protection as a defensive measure.
@@ -8135,328 +8078,342 @@ 
       end if;
 
       Result_Subt := Etype (Function_Id);
-      Definite :=
-        (Is_Definite_Subtype (Underlying_Type (Result_Subt))
-             and then not Is_Tagged_Type (Result_Subt))
-          or else not Requires_Transient_Scope (Underlying_Type (Result_Subt));
 
-      --  Create an access type designating the function's result subtype. We
-      --  use the type of the original call because it may be a call to an
-      --  inherited operation, which the expansion has replaced with the parent
-      --  operation that yields the parent type. Note that this access type
-      --  must be declared before we establish a transient scope, so that it
-      --  receives the proper accessibility level.
+      declare
+         Definite : constant Boolean :=
+           Caller_Known_Size (Func_Call, Result_Subt);
+      begin
+         --  Create an access type designating the function's result subtype.
+         --  We use the type of the original call because it may be a call to
+         --  an inherited operation, which the expansion has replaced with the
+         --  parent operation that yields the parent type. Note that this
+         --  access type must be declared before we establish a transient
+         --  scope, so that it receives the proper accessibility level.
 
-      Ptr_Typ := Make_Temporary (Loc, 'A');
-      Ptr_Typ_Decl :=
-        Make_Full_Type_Declaration (Loc,
-          Defining_Identifier => Ptr_Typ,
-          Type_Definition     =>
-            Make_Access_To_Object_Definition (Loc,
-              All_Present        => True,
-              Subtype_Indication =>
-                New_Occurrence_Of (Etype (Function_Call), Loc)));
+         Ptr_Typ := Make_Temporary (Loc, 'A');
+         Ptr_Typ_Decl :=
+           Make_Full_Type_Declaration (Loc,
+             Defining_Identifier => Ptr_Typ,
+             Type_Definition     =>
+               Make_Access_To_Object_Definition (Loc,
+                 All_Present        => True,
+                 Subtype_Indication =>
+                   New_Occurrence_Of (Etype (Function_Call), Loc)));
 
-      --  The access type and its accompanying object must be inserted after
-      --  the object declaration in the constrained case, so that the function
-      --  call can be passed access to the object. In the indefinite case,
-      --  or if the object declaration is for a return object, the access type
-      --  and object must be inserted before the object, since the object
-      --  declaration is rewritten to be a renaming of a dereference of the
-      --  access object. Note: we need to freeze Ptr_Typ explicitly, because
-      --  the result object is in a different (transient) scope, so won't
-      --  cause freezing.
+         --  The access type and its accompanying object must be inserted after
+         --  the object declaration in the constrained case, so that the
+         --  function call can be passed access to the object. In the
+         --  indefinite case, or if the object declaration is for a return
+         --  object, the access type and object must be inserted before the
+         --  object, since the object declaration is rewritten to be a renaming
+         --  of a dereference of the access object. Note: we need to freeze
+         --  Ptr_Typ explicitly, because the result object is in a different
+         --  (transient) scope, so won't cause freezing.
 
-      if Definite
-        and then not Is_Return_Object (Defining_Identifier (Obj_Decl))
-      then
-         Insert_After_And_Analyze (Obj_Decl, Ptr_Typ_Decl);
-      else
-         Insert_Action (Obj_Decl, Ptr_Typ_Decl);
-      end if;
+         if Definite
+           and then not Is_Return_Object (Defining_Identifier (Obj_Decl))
+         then
+            Insert_After_And_Analyze (Obj_Decl, Ptr_Typ_Decl);
+         else
+            Insert_Action (Obj_Decl, Ptr_Typ_Decl);
+         end if;
 
-      --  Force immediate freezing of Ptr_Typ because Res_Decl will be
-      --  elaborated in an inner (transient) scope and thus won't cause
-      --  freezing by itself.
+         --  Force immediate freezing of Ptr_Typ because Res_Decl will be
+         --  elaborated in an inner (transient) scope and thus won't cause
+         --  freezing by itself.
 
-      declare
-         Ptr_Typ_Freeze_Ref : constant Node_Id :=
-                                New_Occurrence_Of (Ptr_Typ, Loc);
-      begin
-         Set_Parent (Ptr_Typ_Freeze_Ref, Ptr_Typ_Decl);
-         Freeze_Expression (Ptr_Typ_Freeze_Ref);
-      end;
+         declare
+            Ptr_Typ_Freeze_Ref : constant Node_Id :=
+                                   New_Occurrence_Of (Ptr_Typ, Loc);
+         begin
+            Set_Parent (Ptr_Typ_Freeze_Ref, Ptr_Typ_Decl);
+            Freeze_Expression (Ptr_Typ_Freeze_Ref);
+         end;
 
-      --  If the object is a return object of an enclosing build-in-place
-      --  function, then the implicit build-in-place parameters of the
-      --  enclosing function are simply passed along to the called function.
-      --  (Unfortunately, this won't cover the case of extension aggregates
-      --  where the ancestor part is a build-in-place indefinite function
-      --  call that should be passed along the caller's parameters. Currently
-      --  those get mishandled by reassigning the result of the call to the
-      --  aggregate return object, when the call result should really be
-      --  directly built in place in the aggregate and not in a temporary. ???)
+         --  If the object is a return object of an enclosing build-in-place
+         --  function, then the implicit build-in-place parameters of the
+         --  enclosing function are simply passed along to the called function.
+         --  (Unfortunately, this won't cover the case of extension aggregates
+         --  where the ancestor part is a build-in-place indefinite function
+         --  call that should be passed along the caller's parameters.
+         --  Currently those get mishandled by reassigning the result of the
+         --  call to the aggregate return object, when the call result should
+         --  really be directly built in place in the aggregate and not in a
+         --  temporary. ???)
 
-      if Is_Return_Object (Defining_Identifier (Obj_Decl)) then
-         Pass_Caller_Acc := True;
+         if Is_Return_Object (Defining_Identifier (Obj_Decl)) then
+            Pass_Caller_Acc := True;
 
-         --  When the enclosing function has a BIP_Alloc_Form formal then we
-         --  pass it along to the callee (such as when the enclosing function
-         --  has an unconstrained or tagged result type).
+            --  When the enclosing function has a BIP_Alloc_Form formal then we
+            --  pass it along to the callee (such as when the enclosing
+            --  function has an unconstrained or tagged result type).
 
-         if Needs_BIP_Alloc_Form (Encl_Func) then
-            if RTE_Available (RE_Root_Storage_Pool_Ptr) then
-               Pool_Actual :=
-                 New_Occurrence_Of
-                   (Build_In_Place_Formal (Encl_Func, BIP_Storage_Pool), Loc);
+            if Needs_BIP_Alloc_Form (Encl_Func) then
+               if RTE_Available (RE_Root_Storage_Pool_Ptr) then
+                  Pool_Actual :=
+                    New_Occurrence_Of
+                      (Build_In_Place_Formal
+                        (Encl_Func, BIP_Storage_Pool), Loc);
 
-            --  The build-in-place pool formal is not built on e.g. ZFP
+               --  The build-in-place pool formal is not built on e.g. ZFP
 
+               else
+                  Pool_Actual := Empty;
+               end if;
+
+               Add_Unconstrained_Actuals_To_Build_In_Place_Call
+                 (Function_Call  => Func_Call,
+                  Function_Id    => Function_Id,
+                  Alloc_Form_Exp =>
+                    New_Occurrence_Of
+                      (Build_In_Place_Formal (Encl_Func, BIP_Alloc_Form), Loc),
+                  Pool_Actual    => Pool_Actual);
+
+            --  Otherwise, if enclosing function has a definite result subtype,
+            --  then caller allocation will be used.
+
             else
-               Pool_Actual := Empty;
+               Add_Unconstrained_Actuals_To_Build_In_Place_Call
+                 (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
             end if;
 
-            Add_Unconstrained_Actuals_To_Build_In_Place_Call
-              (Function_Call  => Func_Call,
-               Function_Id    => Function_Id,
-               Alloc_Form_Exp =>
+            if Needs_BIP_Finalization_Master (Encl_Func) then
+               Fmaster_Actual :=
                  New_Occurrence_Of
-                   (Build_In_Place_Formal (Encl_Func, BIP_Alloc_Form), Loc),
-               Pool_Actual    => Pool_Actual);
+                   (Build_In_Place_Formal
+                      (Encl_Func, BIP_Finalization_Master), Loc);
+            end if;
 
-         --  Otherwise, if enclosing function has a definite result subtype,
-         --  then caller allocation will be used.
+            --  Retrieve the BIPacc formal from the enclosing function and
+            --  convert it to the access type of the callee's BIP_Object_Access
+            --  formal.
 
-         else
-            Add_Unconstrained_Actuals_To_Build_In_Place_Call
-              (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
-         end if;
+            Caller_Object :=
+              Make_Unchecked_Type_Conversion (Loc,
+                Subtype_Mark =>
+                  New_Occurrence_Of
+                    (Etype
+                       (Build_In_Place_Formal
+                         (Function_Id, BIP_Object_Access)),
+                     Loc),
+                Expression   =>
+                  New_Occurrence_Of
+                    (Build_In_Place_Formal (Encl_Func, BIP_Object_Access),
+                     Loc));
 
-         if Needs_BIP_Finalization_Master (Encl_Func) then
-            Fmaster_Actual :=
-              New_Occurrence_Of
-                (Build_In_Place_Formal
-                   (Encl_Func, BIP_Finalization_Master), Loc);
-         end if;
+         --  In the definite case, add an implicit actual to the function call
+         --  that provides access to the declared object. An unchecked
+         --  conversion to the (specific) result type of the function is
+         --  inserted to handle the case where the object is declared with a
+         --  class-wide type.
 
-         --  Retrieve the BIPacc formal from the enclosing function and convert
-         --  it to the access type of the callee's BIP_Object_Access formal.
+         elsif Definite then
+            Caller_Object :=
+               Make_Unchecked_Type_Conversion (Loc,
+                 Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc),
+                 Expression   => New_Occurrence_Of (Obj_Def_Id, Loc));
 
-         Caller_Object :=
-           Make_Unchecked_Type_Conversion (Loc,
-             Subtype_Mark =>
-               New_Occurrence_Of
-                 (Etype
-                    (Build_In_Place_Formal (Function_Id, BIP_Object_Access)),
-                  Loc),
-             Expression   =>
-               New_Occurrence_Of
-                 (Build_In_Place_Formal (Encl_Func, BIP_Object_Access),
-                  Loc));
+            --  When the function has a controlling result, an allocation-form
+            --  parameter must be passed indicating that the caller is
+            --  allocating the result object. This is needed because such a
+            --  function can be called as a dispatching operation and must be
+            --  treated similarly to functions with indefinite result subtypes.
 
-      --  In the definite case, add an implicit actual to the function call
-      --  that provides access to the declared object. An unchecked conversion
-      --  to the (specific) result type of the function is inserted to handle
-      --  the case where the object is declared with a class-wide type.
+            Add_Unconstrained_Actuals_To_Build_In_Place_Call
+              (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
 
-      elsif Definite then
-         Caller_Object :=
-            Make_Unchecked_Type_Conversion (Loc,
-              Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc),
-              Expression   => New_Occurrence_Of (Obj_Def_Id, Loc));
+         --  The allocation for indefinite library-level objects occurs on the
+         --  heap as opposed to the secondary stack. This accommodates DLLs
+         --  where the secondary stack is destroyed after each library
+         --  unload. This is a hybrid mechanism where a stack-allocated object
+         --  lives on the heap.
 
-         --  When the function has a controlling result, an allocation-form
-         --  parameter must be passed indicating that the caller is allocating
-         --  the result object. This is needed because such a function can be
-         --  called as a dispatching operation and must be treated similarly
-         --  to functions with indefinite result subtypes.
+         elsif Is_Library_Level_Entity (Defining_Identifier (Obj_Decl))
+           and then not Restriction_Active (No_Implicit_Heap_Allocations)
+         then
+            Add_Unconstrained_Actuals_To_Build_In_Place_Call
+              (Func_Call, Function_Id, Alloc_Form => Global_Heap);
+            Caller_Object := Empty;
 
-         Add_Unconstrained_Actuals_To_Build_In_Place_Call
-           (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
+            --  Create a finalization master for the access result type to
+            --  ensure that the heap allocation can properly chain the object
+            --  and later finalize it when the library unit goes out of scope.
 
-      --  The allocation for indefinite library-level objects occurs on the
-      --  heap as opposed to the secondary stack. This accommodates DLLs where
-      --  the secondary stack is destroyed after each library unload. This is
-      --  a hybrid mechanism where a stack-allocated object lives on the heap.
+            if Needs_Finalization (Etype (Func_Call)) then
+               Build_Finalization_Master
+                 (Typ            => Ptr_Typ,
+                  For_Lib_Level  => True,
+                  Insertion_Node => Ptr_Typ_Decl);
 
-      elsif Is_Library_Level_Entity (Defining_Identifier (Obj_Decl))
-        and then not Restriction_Active (No_Implicit_Heap_Allocations)
-      then
-         Add_Unconstrained_Actuals_To_Build_In_Place_Call
-           (Func_Call, Function_Id, Alloc_Form => Global_Heap);
-         Caller_Object := Empty;
+               Fmaster_Actual :=
+                 Make_Attribute_Reference (Loc,
+                   Prefix         =>
+                     New_Occurrence_Of (Finalization_Master (Ptr_Typ), Loc),
+                   Attribute_Name => Name_Unrestricted_Access);
+            end if;
 
-         --  Create a finalization master for the access result type to ensure
-         --  that the heap allocation can properly chain the object and later
-         --  finalize it when the library unit goes out of scope.
+         --  In other indefinite cases, pass an indication to do the allocation
+         --  on the secondary stack and set Caller_Object to Empty so that a
+         --  null value will be passed for the caller's object address. A
+         --  transient scope is established to ensure eventual cleanup of the
+         --  result.
 
-         if Needs_Finalization (Etype (Func_Call)) then
-            Build_Finalization_Master
-              (Typ            => Ptr_Typ,
-               For_Lib_Level  => True,
-               Insertion_Node => Ptr_Typ_Decl);
+         else
+            Add_Unconstrained_Actuals_To_Build_In_Place_Call
+              (Func_Call, Function_Id, Alloc_Form => Secondary_Stack);
+            Caller_Object := Empty;
 
-            Fmaster_Actual :=
-              Make_Attribute_Reference (Loc,
-                Prefix         =>
-                  New_Occurrence_Of (Finalization_Master (Ptr_Typ), Loc),
-                Attribute_Name => Name_Unrestricted_Access);
+            Establish_Transient_Scope (Obj_Decl, Sec_Stack => True);
          end if;
 
-      --  In other indefinite cases, pass an indication to do the allocation
-      --  on the secondary stack and set Caller_Object to Empty so that a null
-      --  value will be passed for the caller's object address. A transient
-      --  scope is established to ensure eventual cleanup of the result.
+         --  Pass along any finalization master actual, which is needed in the
+         --  case where the called function initializes a return object of an
+         --  enclosing build-in-place function.
 
-      else
-         Add_Unconstrained_Actuals_To_Build_In_Place_Call
-           (Func_Call, Function_Id, Alloc_Form => Secondary_Stack);
-         Caller_Object := Empty;
+         Add_Finalization_Master_Actual_To_Build_In_Place_Call
+           (Func_Call  => Func_Call,
+            Func_Id    => Function_Id,
+            Master_Exp => Fmaster_Actual);
 
-         Establish_Transient_Scope (Obj_Decl, Sec_Stack => True);
-      end if;
+         if Nkind (Parent (Obj_Decl)) = N_Extended_Return_Statement
+           and then Has_Task (Result_Subt)
+         then
+            --  Here we're passing along the master that was passed in to this
+            --  function.
 
-      --  Pass along any finalization master actual, which is needed in the
-      --  case where the called function initializes a return object of an
-      --  enclosing build-in-place function.
+            Add_Task_Actuals_To_Build_In_Place_Call
+              (Func_Call, Function_Id,
+               Master_Actual =>
+                 New_Occurrence_Of
+                   (Build_In_Place_Formal (Encl_Func, BIP_Task_Master), Loc));
 
-      Add_Finalization_Master_Actual_To_Build_In_Place_Call
-        (Func_Call  => Func_Call,
-         Func_Id    => Function_Id,
-         Master_Exp => Fmaster_Actual);
+         else
+            Add_Task_Actuals_To_Build_In_Place_Call
+              (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
+         end if;
 
-      if Nkind (Parent (Obj_Decl)) = N_Extended_Return_Statement
-        and then Has_Task (Result_Subt)
-      then
-         --  Here we're passing along the master that was passed in to this
-         --  function.
+         Add_Access_Actual_To_Build_In_Place_Call
+           (Func_Call,
+            Function_Id,
+            Caller_Object,
+            Is_Access => Pass_Caller_Acc);
 
-         Add_Task_Actuals_To_Build_In_Place_Call
-           (Func_Call, Function_Id,
-            Master_Actual =>
-              New_Occurrence_Of
-                (Build_In_Place_Formal (Encl_Func, BIP_Task_Master), Loc));
+         --  Finally, create an access object initialized to a reference to the
+         --  function call. We know this access value cannot be null, so mark
+         --  the entity accordingly to suppress the access check.
 
-      else
-         Add_Task_Actuals_To_Build_In_Place_Call
-           (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
-      end if;
+         Def_Id := Make_Temporary (Loc, 'R', Func_Call);
+         Set_Etype (Def_Id, Ptr_Typ);
+         Set_Is_Known_Non_Null (Def_Id);
 
-      Add_Access_Actual_To_Build_In_Place_Call
-        (Func_Call, Function_Id, Caller_Object, Is_Access => Pass_Caller_Acc);
+         Res_Decl :=
+           Make_Object_Declaration (Loc,
+             Defining_Identifier => Def_Id,
+             Constant_Present    => True,
+             Object_Definition   => New_Occurrence_Of (Ptr_Typ, Loc),
+             Expression          =>
+               Make_Reference (Loc, Relocate_Node (Func_Call)));
 
-      --  Finally, create an access object initialized to a reference to the
-      --  function call. We know this access value cannot be null, so mark the
-      --  entity accordingly to suppress the access check.
+         Insert_After_And_Analyze (Ptr_Typ_Decl, Res_Decl);
 
-      Def_Id := Make_Temporary (Loc, 'R', Func_Call);
-      Set_Etype (Def_Id, Ptr_Typ);
-      Set_Is_Known_Non_Null (Def_Id);
+         --  If the result subtype of the called function is definite and is
+         --  not itself the return expression of an enclosing BIP function,
+         --  then mark the object as having no initialization.
 
-      Res_Decl :=
-        Make_Object_Declaration (Loc,
-          Defining_Identifier => Def_Id,
-          Constant_Present    => True,
-          Object_Definition   => New_Occurrence_Of (Ptr_Typ, Loc),
-          Expression          =>
-            Make_Reference (Loc, Relocate_Node (Func_Call)));
+         if Definite
+           and then not Is_Return_Object (Defining_Identifier (Obj_Decl))
+         then
+            --  The related object declaration is encased in a transient block
+            --  because the build-in-place function call contains at least one
+            --  nested function call that produces a controlled transient
+            --  temporary:
 
-      Insert_After_And_Analyze (Ptr_Typ_Decl, Res_Decl);
+            --    Obj : ... := BIP_Func_Call (Ctrl_Func_Call);
 
-      --  If the result subtype of the called function is definite and is not
-      --  itself the return expression of an enclosing BIP function, then mark
-      --  the object as having no initialization.
+            --  Since the build-in-place expansion decouples the call from the
+            --  object declaration, the finalization machinery lacks the
+            --  context which prompted the generation of the transient
+            --  block. To resolve this scenario, store the build-in-place call.
 
-      if Definite
-        and then not Is_Return_Object (Defining_Identifier (Obj_Decl))
-      then
-         --  The related object declaration is encased in a transient block
-         --  because the build-in-place function call contains at least one
-         --  nested function call that produces a controlled transient
-         --  temporary:
+            if Scope_Is_Transient and then Node_To_Be_Wrapped = Obj_Decl then
+               Set_BIP_Initialization_Call (Obj_Def_Id, Res_Decl);
+            end if;
 
-         --    Obj : ... := BIP_Func_Call (Ctrl_Func_Call);
+            Set_Expression (Obj_Decl, Empty);
+            Set_No_Initialization (Obj_Decl);
 
-         --  Since the build-in-place expansion decouples the call from the
-         --  object declaration, the finalization machinery lacks the context
-         --  which prompted the generation of the transient block. To resolve
-         --  this scenario, store the build-in-place call.
+         --  In case of an indefinite result subtype, or if the call is the
+         --  return expression of an enclosing BIP function, rewrite the object
+         --  declaration as an object renaming where the renamed object is a
+         --  dereference of <function_Call>'reference:
+         --
+         --      Obj : Subt renames <function_call>'Ref.all;
 
-         if Scope_Is_Transient and then Node_To_Be_Wrapped = Obj_Decl then
-            Set_BIP_Initialization_Call (Obj_Def_Id, Res_Decl);
-         end if;
+         else
+            Call_Deref :=
+              Make_Explicit_Dereference (Obj_Loc,
+                Prefix => New_Occurrence_Of (Def_Id, Obj_Loc));
 
-         Set_Expression (Obj_Decl, Empty);
-         Set_No_Initialization (Obj_Decl);
+            Rewrite (Obj_Decl,
+              Make_Object_Renaming_Declaration (Obj_Loc,
+                Defining_Identifier => Make_Temporary (Obj_Loc, 'D'),
+                Subtype_Mark => New_Occurrence_Of (Result_Subt, Obj_Loc),
+                Name => Call_Deref));
 
-      --  In case of an indefinite result subtype, or if the call is the
-      --  return expression of an enclosing BIP function, rewrite the object
-      --  declaration as an object renaming where the renamed object is a
-      --  dereference of <function_Call>'reference:
-      --
-      --      Obj : Subt renames <function_call>'Ref.all;
+            Set_Renamed_Object (Defining_Identifier (Obj_Decl), Call_Deref);
 
-      else
-         Call_Deref :=
-           Make_Explicit_Dereference (Obj_Loc,
-             Prefix => New_Occurrence_Of (Def_Id, Obj_Loc));
+            --  If the original entity comes from source, then mark the new
+            --  entity as needing debug information, even though it's defined
+            --  by a generated renaming that does not come from source, so that
+            --  the Materialize_Entity flag will be set on the entity when
+            --  Debug_Renaming_Declaration is called during analysis.
 
-         Rewrite (Obj_Decl,
-           Make_Object_Renaming_Declaration (Obj_Loc,
-             Defining_Identifier => Make_Temporary (Obj_Loc, 'D'),
-             Subtype_Mark        => New_Occurrence_Of (Result_Subt, Obj_Loc),
-             Name                => Call_Deref));
+            if Comes_From_Source (Obj_Def_Id) then
+               Set_Debug_Info_Needed (Defining_Identifier (Obj_Decl));
+            end if;
 
-         Set_Renamed_Object (Defining_Identifier (Obj_Decl), Call_Deref);
+            Analyze (Obj_Decl);
 
-         --  If the original entity comes from source, then mark the new
-         --  entity as needing debug information, even though it's defined
-         --  by a generated renaming that does not come from source, so that
-         --  the Materialize_Entity flag will be set on the entity when
-         --  Debug_Renaming_Declaration is called during analysis.
+            --  Replace the internal identifier of the renaming declaration's
+            --  entity with identifier of the original object entity. We also
+            --  have to exchange the entities containing their defining
+            --  identifiers to ensure the correct replacement of the object
+            --  declaration by the object renaming declaration to avoid
+            --  homograph conflicts (since the object declaration's defining
+            --  identifier was already entered in current scope). The
+            --  Next_Entity links of the two entities also have to be swapped
+            --  since the entities are part of the return scope's entity list
+            --  and the list structure would otherwise be corrupted. Finally,
+            --  the homonym chain must be preserved as well.
 
-         if Comes_From_Source (Obj_Def_Id) then
-            Set_Debug_Info_Needed (Defining_Identifier (Obj_Decl));
-         end if;
+            declare
+               Ren_Id  : constant Entity_Id := Defining_Entity (Obj_Decl);
+               Next_Id : constant Entity_Id := Next_Entity (Ren_Id);
 
-         Analyze (Obj_Decl);
+            begin
+               Set_Chars (Ren_Id, Chars (Obj_Def_Id));
 
-         --  Replace the internal identifier of the renaming declaration's
-         --  entity with identifier of the original object entity. We also have
-         --  to exchange the entities containing their defining identifiers to
-         --  ensure the correct replacement of the object declaration by the
-         --  object renaming declaration to avoid homograph conflicts (since
-         --  the object declaration's defining identifier was already entered
-         --  in current scope). The Next_Entity links of the two entities also
-         --  have to be swapped since the entities are part of the return
-         --  scope's entity list and the list structure would otherwise be
-         --  corrupted. Finally, the homonym chain must be preserved as well.
+               --  Swap next entity links in preparation for exchanging
+               --  entities.
 
-         declare
-            Ren_Id  : constant Entity_Id := Defining_Entity (Obj_Decl);
-            Next_Id : constant Entity_Id := Next_Entity (Ren_Id);
+               Set_Next_Entity (Ren_Id, Next_Entity (Obj_Def_Id));
+               Set_Next_Entity (Obj_Def_Id, Next_Id);
+               Set_Homonym     (Ren_Id, Homonym (Obj_Def_Id));
 
-         begin
-            Set_Chars (Ren_Id, Chars (Obj_Def_Id));
+               Exchange_Entities (Ren_Id, Obj_Def_Id);
 
-            --  Swap next entity links in preparation for exchanging entities
+               --  Preserve source indication of original declaration, so that
+               --  xref information is properly generated for the right entity.
 
-            Set_Next_Entity (Ren_Id, Next_Entity (Obj_Def_Id));
-            Set_Next_Entity (Obj_Def_Id, Next_Id);
-            Set_Homonym     (Ren_Id, Homonym (Obj_Def_Id));
+               Preserve_Comes_From_Source (Obj_Decl, Original_Node (Obj_Decl));
+               Preserve_Comes_From_Source
+                 (Obj_Def_Id, Original_Node (Obj_Decl));
 
-            Exchange_Entities (Ren_Id, Obj_Def_Id);
+               Set_Comes_From_Source (Ren_Id, False);
+            end;
+         end if;
+      end;
 
-            --  Preserve source indication of original declaration, so that
-            --  xref information is properly generated for the right entity.
-
-            Preserve_Comes_From_Source (Obj_Decl, Original_Node (Obj_Decl));
-            Preserve_Comes_From_Source (Obj_Def_Id, Original_Node (Obj_Decl));
-
-            Set_Comes_From_Source (Ren_Id, False);
-         end;
-      end if;
-
       --  If the object entity has a class-wide Etype, then we need to change
       --  it to the result subtype of the function call, because otherwise the
       --  object will be class-wide without an explicit initialization and