diff options
| -rw-r--r-- | gcc/ada/exp_aggr.adb | 19 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 836 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.ads | 7 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 857 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.ads | 28 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.adb | 28 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 35 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 33 |
8 files changed, 867 insertions, 976 deletions
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 4828406..027a647 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -6603,21 +6603,6 @@ package body Exp_Aggr is then return; - -- Do not expand an aggregate for an array type which contains tasks if - -- the aggregate is associated with an unexpanded return statement of a - -- build-in-place function. The aggregate is expanded when the related - -- return statement (rewritten into an extended return) is processed. - -- This delay ensures that any temporaries and initialization code - -- generated for the aggregate appear in the proper return block and - -- use the correct _chain and _master. - - elsif Has_Task (Base_Type (Etype (N))) - and then Nkind (Parent (N)) = N_Simple_Return_Statement - and then Is_Build_In_Place_Function - (Return_Applies_To (Return_Statement_Entity (Parent (N)))) - then - return; - elsif Present (Component_Associations (N)) and then Nkind (First (Component_Associations (N))) = N_Iterated_Component_Association @@ -6837,7 +6822,9 @@ package body Exp_Aggr is or else Parent_Kind = N_Extension_Aggregate or else Parent_Kind = N_Component_Association or else (Parent_Kind = N_Object_Declaration - and then Needs_Finalization (Typ)) + and then (Needs_Finalization (Typ) + or else Is_Build_In_Place_Return_Object + (Defining_Identifier (Parent_Node)))) or else (Parent_Kind = N_Assignment_Statement and then Inside_Init_Proc) then diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 143e330..7e4c423 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -4895,47 +4895,6 @@ package body Exp_Ch3 is end loop; end Copy_Discr_Checking_Funcs; - ---------------------------------------- - -- Ensure_Activation_Chain_And_Master -- - ---------------------------------------- - - procedure Ensure_Activation_Chain_And_Master (Obj_Decl : Node_Id) is - Def_Id : constant Entity_Id := Defining_Identifier (Obj_Decl); - Expr : constant Node_Id := Expression (Obj_Decl); - Expr_Q : Node_Id; - Typ : constant Entity_Id := Etype (Def_Id); - - begin - pragma Assert (Nkind (Obj_Decl) = N_Object_Declaration); - - if Might_Have_Tasks (Typ) then - Build_Activation_Chain_Entity (Obj_Decl); - - if Has_Task (Typ) then - Build_Master_Entity (Def_Id); - - -- Handle objects initialized with BIP function calls - - elsif Present (Expr) then - if Nkind (Expr) = N_Qualified_Expression then - Expr_Q := Expression (Expr); - else - Expr_Q := Expr; - end if; - - if Is_Build_In_Place_Function_Call (Expr_Q) - or else Present (Unqual_BIP_Iface_Function_Call (Expr_Q)) - or else - (Nkind (Expr_Q) = N_Reference - and then - Is_Build_In_Place_Function_Call (Prefix (Expr_Q))) - then - Build_Master_Entity (Def_Id); - end if; - end if; - end if; - end Ensure_Activation_Chain_And_Master; - ------------------------------ -- Expand_Freeze_Array_Type -- ------------------------------ @@ -6180,6 +6139,47 @@ package body Exp_Ch3 is -- value, it may be possible to build an equivalent aggregate instead, -- and prevent an actual call to the initialization procedure. + function Build_Heap_Or_Pool_Allocator + (Temp_Id : Entity_Id; + Temp_Typ : Entity_Id; + Func_Id : Entity_Id; + Ret_Typ : Entity_Id; + Alloc_Expr : Node_Id) return Node_Id; + -- Create the statements necessary to allocate a return object on the + -- heap or user-defined storage pool. The object may need finalization + -- actions depending on the return type. + -- + -- * Controlled case + -- + -- if BIPfinalizationmaster = null then + -- Temp_Id := <Alloc_Expr>; + -- else + -- declare + -- type Ptr_Typ is access Ret_Typ; + -- for Ptr_Typ'Storage_Pool use + -- Base_Pool (BIPfinalizationmaster.all).all; + -- Local : Ptr_Typ; + -- + -- begin + -- procedure Allocate (...) is + -- begin + -- System.Storage_Pools.Subpools.Allocate_Any (...); + -- end Allocate; + -- + -- Local := <Alloc_Expr>; + -- Temp_Id := Temp_Typ (Local); + -- end; + -- end if; + -- + -- * Non-controlled case + -- + -- Temp_Id := <Alloc_Expr>; + -- + -- Temp_Id is the temporary which is used to reference the internally + -- created object in all allocation forms. Temp_Typ is the type of the + -- temporary. Func_Id is the enclosing function. Ret_Typ is the return + -- type of Func_Id. Alloc_Expr is the actual allocator. + procedure Count_Default_Sized_Task_Stacks (Typ : Entity_Id; Pri_Stacks : out Int; @@ -6322,6 +6322,157 @@ package body Exp_Ch3 is end if; end Build_Equivalent_Aggregate; + ---------------------------------- + -- Build_Heap_Or_Pool_Allocator -- + ---------------------------------- + + function Build_Heap_Or_Pool_Allocator + (Temp_Id : Entity_Id; + Temp_Typ : Entity_Id; + Func_Id : Entity_Id; + Ret_Typ : Entity_Id; + Alloc_Expr : Node_Id) return Node_Id + is + begin + pragma Assert (Is_Build_In_Place_Function (Func_Id)); + + -- Processing for objects that require finalization actions + + if Needs_Finalization (Ret_Typ) then + declare + Decls : constant List_Id := New_List; + Fin_Mas_Id : constant Entity_Id := + Build_In_Place_Formal (Func_Id, BIP_Finalization_Master); + Orig_Expr : constant Node_Id := New_Copy_Tree (Alloc_Expr); + Stmts : constant List_Id := New_List; + Local_Id : Entity_Id; + Pool_Id : Entity_Id; + Ptr_Typ : Entity_Id; + + begin + -- Generate: + -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all; + + Pool_Id := Make_Temporary (Loc, 'P'); + + Append_To (Decls, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Pool_Id, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc), + Name => + Make_Explicit_Dereference (Loc, + Prefix => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Base_Pool), Loc), + Parameter_Associations => New_List ( + Make_Explicit_Dereference (Loc, + Prefix => + New_Occurrence_Of (Fin_Mas_Id, Loc))))))); + + -- Create an access type which uses the storage pool of the + -- caller's master. This additional type is necessary because + -- the finalization master cannot be associated with the type + -- of the temporary. Otherwise the secondary stack allocation + -- will fail. + + -- Generate: + -- type Ptr_Typ is access Ret_Typ; + + Ptr_Typ := Make_Temporary (Loc, 'P'); + + Append_To (Decls, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ptr_Typ, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (Ret_Typ, Loc)))); + + -- Perform minor decoration in order to set the master and the + -- storage pool attributes. + + Mutate_Ekind (Ptr_Typ, E_Access_Type); + Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id); + Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); + + -- Create the temporary, generate: + -- Local_Id : Ptr_Typ; + + Local_Id := Make_Temporary (Loc, 'T'); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Local_Id, + Object_Definition => + New_Occurrence_Of (Ptr_Typ, Loc))); + + -- Allocate the object, generate: + -- Local_Id := <Alloc_Expr>; + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Local_Id, Loc), + Expression => Alloc_Expr)); + + -- Generate: + -- Temp_Id := Temp_Typ (Local_Id); + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Temp_Id, Loc), + Expression => + Unchecked_Convert_To (Temp_Typ, + New_Occurrence_Of (Local_Id, Loc)))); + + -- Wrap the allocation in a block. This is further conditioned + -- by checking the caller finalization master at runtime. A + -- null value indicates a non-existent master, most likely due + -- to a Finalize_Storage_Only allocation. + + -- Generate: + -- if BIPfinalizationmaster = null then + -- Temp_Id := <Orig_Expr>; + -- else + -- declare + -- <Decls> + -- begin + -- <Stmts> + -- end; + -- end if; + + return + Make_If_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => New_Occurrence_Of (Fin_Mas_Id, Loc), + Right_Opnd => Make_Null (Loc)), + + Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Temp_Id, Loc), + Expression => Orig_Expr)), + + Else_Statements => New_List ( + Make_Block_Statement (Loc, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)))); + end; + + -- For all other cases, generate: + -- Temp_Id := <Alloc_Expr>; + + else + return + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Temp_Id, Loc), + Expression => Alloc_Expr); + end if; + end Build_Heap_Or_Pool_Allocator; + ------------------------------------- -- Count_Default_Sized_Task_Stacks -- ------------------------------------- @@ -6869,7 +7020,27 @@ package body Exp_Ch3 is -- also that a Master variable is established (and that the appropriate -- enclosing construct is established as a task master). - Ensure_Activation_Chain_And_Master (N); + if Has_Task (Typ) or else Might_Have_Tasks (Typ) then + Build_Activation_Chain_Entity (N); + + if Has_Task (Typ) then + Build_Master_Entity (Def_Id); + + -- Handle objects initialized with BIP function calls + + elsif Present (Expr) then + Expr_Q := Unqualify (Expr); + + if Is_Build_In_Place_Function_Call (Expr_Q) + or else Present (Unqual_BIP_Iface_Function_Call (Expr_Q)) + or else (Nkind (Expr_Q) = N_Reference + and then + Is_Build_In_Place_Function_Call (Prefix (Expr_Q))) + then + Build_Master_Entity (Def_Id); + end if; + end if; + end if; -- If No_Implicit_Heap_Allocations or No_Implicit_Task_Allocations -- restrictions are active then default-sized secondary stacks are @@ -6905,6 +7076,7 @@ package body Exp_Ch3 is -- Default initialization required, and no expression present if No (Expr) then + Expr_Q := Expr; -- If we have a type with a variant part, the initialization proc -- will contain implicit tests of the discriminant values, which @@ -6964,7 +7136,9 @@ package body Exp_Ch3 is end if; end if; - Default_Initialize_Object (Init_After); + if not Is_Build_In_Place_Return_Object (Def_Id) then + Default_Initialize_Object (Init_After); + end if; -- Generate attribute for Persistent_BSS if needed @@ -7022,7 +7196,9 @@ package body Exp_Ch3 is Expander_Mode_Restore; end if; - Convert_Aggr_In_Object_Decl (N); + if not Is_Build_In_Place_Return_Object (Def_Id) then + Convert_Aggr_In_Object_Decl (N); + end if; -- Ada 2005 (AI-318-02): If the initialization expression is a call -- to a build-in-place function, then access to the declared object @@ -7091,13 +7267,12 @@ package body Exp_Ch3 is then pragma Assert (Is_Class_Wide_Type (Typ)); - -- If the object is a return object of an inherently limited type, - -- which implies build-in-place treatment, bypass the special + -- If the object is a built-in-place return object, bypass special -- treatment of class-wide interface initialization below. In this -- case, the expansion of the return statement will take care of -- creating the object (via allocator) and initializing it. - if Is_Return_Object (Def_Id) and then Is_Limited_View (Typ) then + if Is_Build_In_Place_Return_Object (Def_Id) then null; elsif Tagged_Type_Expansion then @@ -7323,9 +7498,12 @@ package body Exp_Ch3 is Set_SPARK_Pragma_Inherited (Def_Id, Save_SPI); end; end; - end if; - return; + return; + + else + return; + end if; -- Common case of explicit object initialization @@ -7598,11 +7776,11 @@ package body Exp_Ch3 is Name => New_Occurrence_Of (Def_Id, Loc), Expression => Relocate_Node (Expr)); begin - Set_Expression (N, Empty); - Set_No_Initialization (N); Set_Assignment_OK (Name (Stat)); Set_No_Ctrl_Actions (Stat); - Insert_After_And_Analyze (Init_After, Stat); + Insert_Action_After (Init_After, Stat); + Set_Expression (N, Empty); + Set_No_Initialization (N); end; end if; end if; @@ -7699,6 +7877,554 @@ package body Exp_Ch3 is end; end if; + -- If this is the return object of a build-in-place function, locate the + -- implicit BIPaccess parameter designating the caller-supplied return + -- object and convert the declaration to a renaming of a dereference of + -- this parameter. If the declaration includes an expression, add an + -- assignment statement to ensure the return object gets initialized. + + -- Result : T [:= <expression>]; + + -- is converted to + + -- Result : T renames BIPaccess.all; + -- [Result := <expression>;] + + -- in the constrained case, or to + + -- type Txx is access all ...; + -- Rxx : Txx := null; + + -- if BIPalloc = 1 then + -- Rxx := BIPaccess; + -- elsif BIPalloc = 2 then + -- Rxx := new <expression-type>[storage_pool = + -- system__secondary_stack__ss_pool][procedure_to_call = + -- system__secondary_stack__ss_allocate]; + -- elsif BIPalloc = 3 then + -- Rxx := new <expression-type> + -- elsif BIPalloc = 4 then + -- Pxx : system__storage_pools__root_storage_pool renames + -- BIPstoragepool.all; + -- Rxx := new <expression-type>[storage_pool = + -- Pxx][procedure_to_call = + -- system__storage_pools__allocate_any]; + -- else + -- [program_error "build in place mismatch"] + -- end if; + + -- Result : T renames Rxx.all; + -- Result := <expression>; + + -- in the unconstrained case. + + if Is_Build_In_Place_Return_Object (Def_Id) then + declare + Func_Id : constant Entity_Id := + Return_Applies_To (Scope (Def_Id)); + Ret_Obj_Typ : constant Entity_Id := Etype (Def_Id); + + Init_Stmt : Node_Id; + Obj_Acc_Formal : Entity_Id; + + begin + -- Retrieve the implicit access parameter passed by the caller + + Obj_Acc_Formal := + Build_In_Place_Formal (Func_Id, BIP_Object_Access); + + -- If the return object's declaration includes an expression + -- and the declaration isn't marked as No_Initialization, then + -- we need to generate an assignment to the object and insert + -- it after the declaration before rewriting it as a renaming + -- (otherwise we'll lose the initialization). The case where + -- the result type is an interface (or class-wide interface) + -- is also excluded because the context of the function call + -- must be unconstrained, so the initialization will always + -- be done as part of an allocator evaluation (storage pool + -- or secondary stack), never to a constrained target object + -- passed in by the caller. Besides the assignment being + -- unneeded in this case, it avoids problems with trying to + -- generate a dispatching assignment when the return expression + -- is a nonlimited descendant of a limited interface (the + -- interface has no assignment operation). + + if Present (Expr_Q) + and then not Is_Delayed_Aggregate (Expr_Q) + and then not No_Initialization (N) + and then not Is_Interface (Etype (Def_Id)) + then + if Is_Class_Wide_Type (Etype (Def_Id)) + and then not Is_Class_Wide_Type (Etype (Expr_Q)) + then + Init_Stmt := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Def_Id, Loc), + Expression => + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (Etype (Def_Id), Loc), + Expression => New_Copy_Tree (Expr_Q))); + + else + Init_Stmt := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Def_Id, Loc), + Expression => New_Copy_Tree (Expr_Q)); + end if; + + Set_Assignment_OK (Name (Init_Stmt)); + Set_No_Ctrl_Actions (Init_Stmt); + + else + Init_Stmt := Empty; + end if; + + -- When the function's subtype is unconstrained, a run-time + -- test may be needed to decide the form of allocation to use + -- for the return object. The function has an implicit formal + -- parameter indicating this. If the BIP_Alloc_Form formal has + -- the value one, then the caller has passed access to an + -- existing object for use as the return object. If the value + -- is two, then the return object must be allocated on the + -- secondary stack. Otherwise, the object must be allocated in + -- a storage pool. We generate an if statement to test the + -- implicit allocation formal and initialize a local access + -- value appropriately, creating allocators in the secondary + -- stack and global heap cases. The special formal also exists + -- and must be tested when the function has a tagged result, + -- even when the result subtype is constrained, because in + -- general such functions can be called in dispatching contexts + -- and must be handled similarly to functions with a class-wide + -- result. + + if Needs_BIP_Alloc_Form (Func_Id) then + declare + Desig_Typ : constant Entity_Id := + (if Ekind (Ret_Obj_Typ) = E_Array_Subtype + then Etype (Func_Id) else Ret_Obj_Typ); + -- Ensure that the we use a fat pointer when allocating + -- an unconstrained array on the heap. In this case the + -- result object type is a constrained array type even + -- though the function type is unconstrained. + Obj_Alloc_Formal : constant Entity_Id := + Build_In_Place_Formal (Func_Id, BIP_Alloc_Form); + Pool_Id : constant Entity_Id := + Make_Temporary (Loc, 'P'); + + Alloc_Obj_Id : Entity_Id; + Alloc_Obj_Decl : Node_Id; + Alloc_Stmt : Node_Id; + Guard_Except : Node_Id; + Heap_Allocator : Node_Id; + Pool_Decl : Node_Id; + Pool_Allocator : Node_Id; + Ptr_Type_Decl : Node_Id; + Ref_Type : Entity_Id; + SS_Allocator : Node_Id; + + begin + -- Create an access type designating the function's + -- result subtype. + + Ref_Type := Make_Temporary (Loc, 'A'); + + Ptr_Type_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ref_Type, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + New_Occurrence_Of (Desig_Typ, Loc))); + + Insert_Action (N, Ptr_Type_Decl); + + -- Create an access object that will be initialized to an + -- access value denoting the return object, either coming + -- from an implicit access value passed in by the caller + -- or from the result of an allocator. + + Alloc_Obj_Id := Make_Temporary (Loc, 'R'); + Set_Etype (Alloc_Obj_Id, Ref_Type); + + Alloc_Obj_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Alloc_Obj_Id, + Object_Definition => + New_Occurrence_Of (Ref_Type, Loc)); + + Insert_Action (N, Alloc_Obj_Decl); + + -- Create allocators for both the secondary stack and + -- global heap. If there's an initialization expression, + -- then create these as initialized allocators. + + if Present (Expr_Q) + and then not Is_Delayed_Aggregate (Expr_Q) + and then not No_Initialization (N) + then + -- Always use the type of the expression for the + -- qualified expression, rather than the result type. + -- In general we cannot always use the result type + -- for the allocator, because the expression might be + -- of a specific type, such as in the case of an + -- aggregate or even a nonlimited object when the + -- result type is a limited class-wide interface type. + + Heap_Allocator := + Make_Allocator (Loc, + Expression => + Make_Qualified_Expression (Loc, + Subtype_Mark => + New_Occurrence_Of (Etype (Expr_Q), Loc), + Expression => New_Copy_Tree (Expr_Q))); + + else + -- If the function returns a class-wide type we cannot + -- use the return type for the allocator. Instead we + -- use the type of the expression, which must be an + -- aggregate of a definite type. + + if Is_Class_Wide_Type (Ret_Obj_Typ) then + Heap_Allocator := + Make_Allocator (Loc, + Expression => + New_Occurrence_Of (Etype (Expr_Q), Loc)); + + else + Heap_Allocator := + Make_Allocator (Loc, + Expression => + New_Occurrence_Of (Ret_Obj_Typ, Loc)); + end if; + + -- If the object requires default initialization then + -- that will happen later following the elaboration of + -- the object renaming. If we don't turn it off here + -- then the object will be default initialized twice. + + Set_No_Initialization (Heap_Allocator); + end if; + + -- Set the flag indicating that the allocator came from + -- a build-in-place return statement, so we can avoid + -- adjusting the allocated object. Note that this flag + -- will be inherited by the copies made below. + + Set_Alloc_For_BIP_Return (Heap_Allocator); + + -- The Pool_Allocator is just like the Heap_Allocator, + -- except we set Storage_Pool and Procedure_To_Call so + -- it will use the user-defined storage pool. + + Pool_Allocator := New_Copy_Tree (Heap_Allocator); + + pragma Assert (Alloc_For_BIP_Return (Pool_Allocator)); + + -- Do not generate the renaming of the build-in-place + -- pool parameter on ZFP because the parameter is not + -- created in the first place. + + if RTE_Available (RE_Root_Storage_Pool_Ptr) then + Pool_Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Pool_Id, + Subtype_Mark => + New_Occurrence_Of + (RTE (RE_Root_Storage_Pool), Loc), + Name => + Make_Explicit_Dereference (Loc, + New_Occurrence_Of + (Build_In_Place_Formal + (Func_Id, BIP_Storage_Pool), Loc))); + Set_Storage_Pool (Pool_Allocator, Pool_Id); + Set_Procedure_To_Call + (Pool_Allocator, RTE (RE_Allocate_Any)); + else + Pool_Decl := Make_Null_Statement (Loc); + end if; + + -- If the No_Allocators restriction is active, then only + -- an allocator for secondary stack allocation is needed. + -- It's OK for such allocators to have Comes_From_Source + -- set to False, because gigi knows not to flag them as + -- being a violation of No_Implicit_Heap_Allocations. + + if Restriction_Active (No_Allocators) then + SS_Allocator := Heap_Allocator; + Heap_Allocator := Make_Null (Loc); + Pool_Allocator := Make_Null (Loc); + + -- Otherwise the heap and pool allocators may be needed, + -- so we make another allocator for secondary stack + -- allocation. + + else + SS_Allocator := New_Copy_Tree (Heap_Allocator); + + pragma Assert (Alloc_For_BIP_Return (SS_Allocator)); + + -- The heap and pool allocators are marked as + -- Comes_From_Source since they correspond to an + -- explicit user-written allocator (that is, it will + -- only be executed on behalf of callers that call the + -- function as initialization for such an allocator). + -- Prevents errors when No_Implicit_Heap_Allocations + -- is in force. + + Set_Comes_From_Source (Heap_Allocator, True); + Set_Comes_From_Source (Pool_Allocator, True); + end if; + + -- The allocator is returned on the secondary stack + + Check_Restriction (No_Secondary_Stack, N); + Set_Storage_Pool (SS_Allocator, RTE (RE_SS_Pool)); + Set_Procedure_To_Call + (SS_Allocator, RTE (RE_SS_Allocate)); + + -- The allocator is returned on the secondary stack, + -- so indicate that the function return, as well as + -- all blocks that encloses the allocator, must not + -- release it. The flags must be set now because + -- the decision to use the secondary stack is done + -- very late in the course of expanding the return + -- statement, past the point where these flags are + -- normally set. + + Set_Uses_Sec_Stack (Func_Id); + Set_Uses_Sec_Stack (Scope (Def_Id)); + Set_Sec_Stack_Needed_For_Return (Scope (Def_Id)); + + -- Guard against poor expansion on the caller side by + -- using a raise statement to catch out-of-range values + -- of formal parameter BIP_Alloc_Form. + + if Exceptions_OK then + Guard_Except := + Make_Raise_Program_Error (Loc, + Reason => PE_Build_In_Place_Mismatch); + else + Guard_Except := Make_Null_Statement (Loc); + end if; + + -- Create an if statement to test the BIP_Alloc_Form + -- formal and initialize the access object to either the + -- BIP_Object_Access formal (BIP_Alloc_Form = + -- Caller_Allocation), the result of allocating the + -- object in the secondary stack (BIP_Alloc_Form = + -- Secondary_Stack), or else an allocator to create the + -- return object in the heap or user-defined pool + -- (BIP_Alloc_Form = Global_Heap or User_Storage_Pool). + + -- ??? An unchecked type conversion must be made in the + -- case of assigning the access object formal to the + -- local access object, because a normal conversion would + -- be illegal in some cases (such as converting access- + -- to-unconstrained to access-to-constrained), but the + -- the unchecked conversion will presumably fail to work + -- right in just such cases. It's not clear at all how to + -- handle this. ??? + + Alloc_Stmt := + Make_If_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + New_Occurrence_Of (Obj_Alloc_Formal, Loc), + Right_Opnd => + Make_Integer_Literal (Loc, + UI_From_Int (BIP_Allocation_Form'Pos + (Caller_Allocation)))), + + Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => + New_Occurrence_Of (Alloc_Obj_Id, Loc), + Expression => + Unchecked_Convert_To + (Ref_Type, + New_Occurrence_Of (Obj_Acc_Formal, Loc)))), + + Elsif_Parts => New_List ( + Make_Elsif_Part (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + New_Occurrence_Of (Obj_Alloc_Formal, Loc), + Right_Opnd => + Make_Integer_Literal (Loc, + UI_From_Int (BIP_Allocation_Form'Pos + (Secondary_Stack)))), + + Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => + New_Occurrence_Of (Alloc_Obj_Id, Loc), + Expression => SS_Allocator))), + + Make_Elsif_Part (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + New_Occurrence_Of (Obj_Alloc_Formal, Loc), + Right_Opnd => + Make_Integer_Literal (Loc, + UI_From_Int (BIP_Allocation_Form'Pos + (Global_Heap)))), + + Then_Statements => New_List ( + Build_Heap_Or_Pool_Allocator + (Temp_Id => Alloc_Obj_Id, + Temp_Typ => Ref_Type, + Func_Id => Func_Id, + Ret_Typ => Desig_Typ, + Alloc_Expr => Heap_Allocator))), + + -- ???If all is well, we can put the following + -- 'elsif' in the 'else', but this is a useful + -- self-check in case caller and callee don't agree + -- on whether BIPAlloc and so on should be passed. + + Make_Elsif_Part (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + New_Occurrence_Of (Obj_Alloc_Formal, Loc), + Right_Opnd => + Make_Integer_Literal (Loc, + UI_From_Int (BIP_Allocation_Form'Pos + (User_Storage_Pool)))), + + Then_Statements => New_List ( + Pool_Decl, + Build_Heap_Or_Pool_Allocator + (Temp_Id => Alloc_Obj_Id, + Temp_Typ => Ref_Type, + Func_Id => Func_Id, + Ret_Typ => Desig_Typ, + Alloc_Expr => Pool_Allocator)))), + + -- Raise Program_Error if it's none of the above; + -- this is a compiler bug. + + Else_Statements => New_List (Guard_Except)); + + -- If a separate initialization assignment was created + -- earlier, append that following the assignment of the + -- implicit access formal to the access object, to ensure + -- that the return object is initialized in that case. In + -- this situation, the target of the assignment must be + -- rewritten to denote a dereference of the access to the + -- return object passed in by the caller. + + if Present (Init_Stmt) then + Set_Name (Init_Stmt, + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc))); + Set_Assignment_OK (Name (Init_Stmt)); + + Append_To (Then_Statements (Alloc_Stmt), Init_Stmt); + Init_Stmt := Empty; + end if; + + Insert_Action (N, Alloc_Stmt, Suppress => All_Checks); + + -- From now on, the type of the return object is the + -- designated type. + + Set_Etype (Def_Id, Desig_Typ); + + -- Remember the local access object for use in the + -- dereference of the renaming created below. + + Obj_Acc_Formal := Alloc_Obj_Id; + end; + + -- When the function's subtype is unconstrained and a run-time + -- test is not needed, we nevertheless need to build the return + -- using the function's result subtype. + + elsif not Is_Constrained (Underlying_Type (Etype (Func_Id))) then + declare + Alloc_Obj_Id : Entity_Id; + Alloc_Obj_Decl : Node_Id; + Ptr_Type_Decl : Node_Id; + Ref_Type : Entity_Id; + + begin + -- Create an access type designating the function's + -- result subtype. + + Ref_Type := Make_Temporary (Loc, 'A'); + + Ptr_Type_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ref_Type, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + New_Occurrence_Of (Ret_Obj_Typ, Loc))); + + Insert_Action (N, Ptr_Type_Decl); + + -- Create an access object initialized to the conversion + -- of the implicit access value passed in by the caller. + + Alloc_Obj_Id := Make_Temporary (Loc, 'R'); + + -- See the ??? comment a few lines above about the use of + -- an unchecked conversion here. + + Alloc_Obj_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Alloc_Obj_Id, + Object_Definition => + New_Occurrence_Of (Ref_Type, Loc), + Expression => + Unchecked_Convert_To + (Ref_Type, + New_Occurrence_Of (Obj_Acc_Formal, Loc))); + + Insert_Action (N, Alloc_Obj_Decl, Suppress => All_Checks); + + -- Remember the local access object for use in the + -- dereference of the renaming created below. + + Obj_Acc_Formal := Alloc_Obj_Id; + end; + end if; + + -- Initialize the object now that it has got its final subtype, + -- but before rewriting it as a renaming. + + if No (Expr_Q) then + Default_Initialize_Object (Init_After); + + elsif Is_Delayed_Aggregate (Expr_Q) + and then not No_Initialization (N) + then + Convert_Aggr_In_Object_Decl (N); + + elsif Present (Init_Stmt) then + Insert_Action_After (Init_After, Init_Stmt); + Set_Expression (N, Empty); + end if; + + -- Replace the return object declaration with a renaming of a + -- dereference of the access value designating the return object. + + Expr_Q := + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Obj_Acc_Formal, Loc)); + Set_Etype (Expr_Q, Etype (Def_Id)); + + Rewrite_As_Renaming := True; + end; + end if; + -- Final transformation - turn the object declaration into a renaming -- if appropriate. If this is the completion of a deferred constant -- declaration, then this transformation generates what would be @@ -7707,8 +8433,8 @@ package body Exp_Ch3 is if Rewrite_As_Renaming then Rewrite (N, Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Defining_Identifier (N), - Subtype_Mark => Obj_Def, + Defining_Identifier => Def_Id, + Subtype_Mark => New_Occurrence_Of (Etype (Def_Id), Loc), Name => Expr_Q)); -- We do not analyze this renaming declaration, because all its @@ -7716,7 +8442,7 @@ package body Exp_Ch3 is -- ahead and analyze it, we would in effect be trying to generate -- another declaration of X, which won't do. - Set_Renamed_Object (Defining_Identifier (N), Expr_Q); + Set_Renamed_Object (Def_Id, Expr_Q); Set_Analyzed (N); -- We do need to deal with debug issues for this renaming diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads index ca8a550..f7d43c4 100644 --- a/gcc/ada/exp_ch3.ads +++ b/gcc/ada/exp_ch3.ads @@ -113,13 +113,6 @@ package Exp_Ch3 is -- Build the body of the equality function Body_Id for the untagged variant -- record Typ with the given parameters specification list. - procedure Ensure_Activation_Chain_And_Master (Obj_Decl : Node_Id); - -- If tasks are being declared (or might be declared) by the given object - -- declaration then ensure to have an activation chain defined for the - -- tasks (has no effect if we already have one), and also that a Master - -- variable is established (and that the appropriate enclosing construct - -- is established as a task master). - function Freeze_Type (N : Node_Id) return Boolean; -- This function executes the freezing actions associated with the given -- freeze type node N and returns True if the node is to be deleted. We diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 14e0498..d6d9d00 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -5079,48 +5079,15 @@ package body Exp_Ch6 is -- (in which case default initial values might need to be set)). procedure Expand_N_Extended_Return_Statement (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - - function Build_Heap_Or_Pool_Allocator - (Temp_Id : Entity_Id; - Temp_Typ : Entity_Id; - Func_Id : Entity_Id; - Ret_Typ : Entity_Id; - Alloc_Expr : Node_Id) return Node_Id; - -- Create the statements necessary to allocate a return object on the - -- heap or user-defined storage pool. The object may need finalization - -- actions depending on the return type. - -- - -- * Controlled case - -- - -- if BIPfinalizationmaster = null then - -- Temp_Id := <Alloc_Expr>; - -- else - -- declare - -- type Ptr_Typ is access Ret_Typ; - -- for Ptr_Typ'Storage_Pool use - -- Base_Pool (BIPfinalizationmaster.all).all; - -- Local : Ptr_Typ; - -- - -- begin - -- procedure Allocate (...) is - -- begin - -- System.Storage_Pools.Subpools.Allocate_Any (...); - -- end Allocate; - -- - -- Local := <Alloc_Expr>; - -- Temp_Id := Temp_Typ (Local); - -- end; - -- end if; - -- - -- * Non-controlled case - -- - -- Temp_Id := <Alloc_Expr>; - -- - -- Temp_Id is the temporary which is used to reference the internally - -- created object in all allocation forms. Temp_Typ is the type of the - -- temporary. Func_Id is the enclosing function. Ret_Typ is the return - -- type of Func_Id. Alloc_Expr is the actual allocator. + Loc : constant Source_Ptr := Sloc (N); + Func_Id : constant Entity_Id := + Return_Applies_To (Return_Statement_Entity (N)); + Is_BIP_Func : constant Boolean := + Is_Build_In_Place_Function (Func_Id); + Ret_Obj_Id : constant Entity_Id := + First_Entity (Return_Statement_Entity (N)); + Ret_Obj_Decl : constant Node_Id := Parent (Ret_Obj_Id); + Ret_Typ : constant Entity_Id := Etype (Func_Id); function Move_Activation_Chain (Func_Id : Entity_Id) return Node_Id; -- Construct a call to System.Tasking.Stages.Move_Activation_Chain @@ -5132,173 +5099,6 @@ package body Exp_Ch6 is -- Func_Id is the entity of the function where the extended return -- statement appears. - ---------------------------------- - -- Build_Heap_Or_Pool_Allocator -- - ---------------------------------- - - function Build_Heap_Or_Pool_Allocator - (Temp_Id : Entity_Id; - Temp_Typ : Entity_Id; - Func_Id : Entity_Id; - Ret_Typ : Entity_Id; - Alloc_Expr : Node_Id) return Node_Id - is - begin - pragma Assert (Is_Build_In_Place_Function (Func_Id)); - - -- Processing for objects that require finalization actions - - if Needs_Finalization (Ret_Typ) then - declare - Decls : constant List_Id := New_List; - Fin_Mas_Id : constant Entity_Id := - Build_In_Place_Formal - (Func_Id, BIP_Finalization_Master); - Orig_Expr : constant Node_Id := - New_Copy_Tree - (Source => Alloc_Expr, - Scopes_In_EWA_OK => True); - Stmts : constant List_Id := New_List; - Desig_Typ : Entity_Id; - Local_Id : Entity_Id; - Pool_Id : Entity_Id; - Ptr_Typ : Entity_Id; - - begin - -- Generate: - -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all; - - Pool_Id := Make_Temporary (Loc, 'P'); - - Append_To (Decls, - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Pool_Id, - Subtype_Mark => - New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc), - Name => - Make_Explicit_Dereference (Loc, - Prefix => - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Base_Pool), Loc), - Parameter_Associations => New_List ( - Make_Explicit_Dereference (Loc, - Prefix => - New_Occurrence_Of (Fin_Mas_Id, Loc))))))); - - -- Create an access type which uses the storage pool of the - -- caller's master. This additional type is necessary because - -- the finalization master cannot be associated with the type - -- of the temporary. Otherwise the secondary stack allocation - -- will fail. - - Desig_Typ := Ret_Typ; - - -- Ensure that the build-in-place machinery uses a fat pointer - -- when allocating an unconstrained array on the heap. In this - -- case the result object type is a constrained array type even - -- though the function type is unconstrained. - - if Ekind (Desig_Typ) = E_Array_Subtype then - Desig_Typ := Base_Type (Desig_Typ); - end if; - - -- Generate: - -- type Ptr_Typ is access Desig_Typ; - - Ptr_Typ := Make_Temporary (Loc, 'P'); - - Append_To (Decls, - Make_Full_Type_Declaration (Loc, - Defining_Identifier => Ptr_Typ, - Type_Definition => - Make_Access_To_Object_Definition (Loc, - Subtype_Indication => - New_Occurrence_Of (Desig_Typ, Loc)))); - - -- Perform minor decoration in order to set the master and the - -- storage pool attributes. - - Mutate_Ekind (Ptr_Typ, E_Access_Type); - Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id); - Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); - - -- Create the temporary, generate: - -- Local_Id : Ptr_Typ; - - Local_Id := Make_Temporary (Loc, 'T'); - - Append_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => Local_Id, - Object_Definition => - New_Occurrence_Of (Ptr_Typ, Loc))); - - -- Allocate the object, generate: - -- Local_Id := <Alloc_Expr>; - - Append_To (Stmts, - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Local_Id, Loc), - Expression => Alloc_Expr)); - - -- Generate: - -- Temp_Id := Temp_Typ (Local_Id); - - Append_To (Stmts, - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Temp_Id, Loc), - Expression => - Unchecked_Convert_To (Temp_Typ, - New_Occurrence_Of (Local_Id, Loc)))); - - -- Wrap the allocation in a block. This is further conditioned - -- by checking the caller finalization master at runtime. A - -- null value indicates a non-existent master, most likely due - -- to a Finalize_Storage_Only allocation. - - -- Generate: - -- if BIPfinalizationmaster = null then - -- Temp_Id := <Orig_Expr>; - -- else - -- declare - -- <Decls> - -- begin - -- <Stmts> - -- end; - -- end if; - - return - Make_If_Statement (Loc, - Condition => - Make_Op_Eq (Loc, - Left_Opnd => New_Occurrence_Of (Fin_Mas_Id, Loc), - Right_Opnd => Make_Null (Loc)), - - Then_Statements => New_List ( - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Temp_Id, Loc), - Expression => Orig_Expr)), - - Else_Statements => New_List ( - Make_Block_Statement (Loc, - Declarations => Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Stmts)))); - end; - - -- For all other cases, generate: - -- Temp_Id := <Alloc_Expr>; - - else - return - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Temp_Id, Loc), - Expression => Alloc_Expr); - end if; - end Build_Heap_Or_Pool_Allocator; - --------------------------- -- Move_Activation_Chain -- --------------------------- @@ -5331,15 +5131,6 @@ package body Exp_Ch6 is -- Local variables - Func_Id : constant Entity_Id := - Return_Applies_To (Return_Statement_Entity (N)); - Is_BIP_Func : constant Boolean := - Is_Build_In_Place_Function (Func_Id); - Ret_Obj_Id : constant Entity_Id := - First_Entity (Return_Statement_Entity (N)); - Ret_Obj_Decl : constant Node_Id := Parent (Ret_Obj_Id); - Ret_Typ : constant Entity_Id := Etype (Func_Id); - Exp : Node_Id; HSS : Node_Id; Result : Node_Id; @@ -5508,13 +5299,6 @@ package body Exp_Ch6 is end; end if; - -- Build a simple_return_statement that returns the return object - - Return_Stmt := - Make_Simple_Return_Statement (Loc, - Expression => New_Occurrence_Of (Ret_Obj_Id, Loc)); - Append_To (Stmts, Return_Stmt); - HSS := Make_Handled_Sequence_Of_Statements (Loc, Stmts); end if; @@ -5535,571 +5319,12 @@ package body Exp_Ch6 is Set_Identifier (Result, New_Occurrence_Of (Return_Statement_Entity (N), Loc)); - -- If the object decl was already rewritten as a renaming, then we - -- don't want to do the object allocation and transformation of - -- the return object declaration to a renaming. This case occurs - -- when the return object is initialized by a call to another - -- build-in-place function, and that function is responsible for - -- the allocation of the return object. - - if Is_BIP_Func - and then Nkind (Ret_Obj_Decl) = N_Object_Renaming_Declaration - then - pragma Assert - (Nkind (Original_Node (Ret_Obj_Decl)) = N_Object_Declaration - and then - - -- It is a regular BIP object declaration - - (Is_Build_In_Place_Function_Call - (Expression (Original_Node (Ret_Obj_Decl))) - - -- It is a BIP object declaration that displaces the pointer - -- to the object to reference a converted interface type. - - or else - Present (Unqual_BIP_Iface_Function_Call - (Expression (Original_Node (Ret_Obj_Decl)))))); - - elsif Is_BIP_Func then - - -- Locate the implicit access parameter associated with the - -- caller-supplied return object and convert the return - -- statement's return object declaration to a renaming of a - -- dereference of the access parameter. If the return object's - -- declaration includes an expression that has not already been - -- expanded as separate assignments, then add an assignment - -- statement to ensure the return object gets initialized. - - -- declare - -- Result : T [:= <expression>]; - -- begin - -- ... - - -- is converted to - - -- declare - -- Result : T renames FuncRA.all; - -- [Result := <expression;] - -- begin - -- ... - - declare - Ret_Obj_Expr : constant Node_Id := Expression (Ret_Obj_Decl); - Ret_Obj_Typ : constant Entity_Id := Etype (Ret_Obj_Id); - - Init_Assignment : Node_Id := Empty; - Obj_Acc_Formal : Entity_Id; - Obj_Acc_Deref : Node_Id; - Obj_Alloc_Formal : Entity_Id; - - begin - -- Retrieve the implicit access parameter passed by the caller - - Obj_Acc_Formal := - Build_In_Place_Formal (Func_Id, BIP_Object_Access); - - -- If the return object's declaration includes an expression - -- and the declaration isn't marked as No_Initialization, then - -- we need to generate an assignment to the object and insert - -- it after the declaration before rewriting it as a renaming - -- (otherwise we'll lose the initialization). The case where - -- the result type is an interface (or class-wide interface) - -- is also excluded because the context of the function call - -- must be unconstrained, so the initialization will always - -- be done as part of an allocator evaluation (storage pool - -- or secondary stack), never to a constrained target object - -- passed in by the caller. Besides the assignment being - -- unneeded in this case, it avoids problems with trying to - -- generate a dispatching assignment when the return expression - -- is a nonlimited descendant of a limited interface (the - -- interface has no assignment operation). - - if Present (Ret_Obj_Expr) - and then not No_Initialization (Ret_Obj_Decl) - and then not Is_Interface (Ret_Obj_Typ) - then - Init_Assignment := - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Ret_Obj_Id, Loc), - Expression => - New_Copy_Tree - (Source => Ret_Obj_Expr, - Scopes_In_EWA_OK => True)); - - Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id)); - Set_Assignment_OK (Name (Init_Assignment)); - Set_No_Ctrl_Actions (Init_Assignment); - - Set_Parent (Name (Init_Assignment), Init_Assignment); - Set_Parent (Expression (Init_Assignment), Init_Assignment); - - Set_Expression (Ret_Obj_Decl, Empty); - - if Is_Class_Wide_Type (Etype (Ret_Obj_Id)) - and then not Is_Class_Wide_Type - (Etype (Expression (Init_Assignment))) - then - Rewrite (Expression (Init_Assignment), - Make_Type_Conversion (Loc, - Subtype_Mark => - New_Occurrence_Of (Etype (Ret_Obj_Id), Loc), - Expression => - Relocate_Node (Expression (Init_Assignment)))); - end if; - - -- In the case of functions where the calling context can - -- determine the form of allocation needed, initialization - -- is done with each part of the if statement that handles - -- the different forms of allocation (this is true for - -- unconstrained, tagged, and controlled result subtypes). - - if not Needs_BIP_Alloc_Form (Func_Id) then - Insert_After (Ret_Obj_Decl, Init_Assignment); - end if; - end if; - - -- When the function's subtype is unconstrained, a run-time - -- test may be needed to decide the form of allocation to use - -- for the return object. The function has an implicit formal - -- parameter indicating this. If the BIP_Alloc_Form formal has - -- the value one, then the caller has passed access to an - -- existing object for use as the return object. If the value - -- is two, then the return object must be allocated on the - -- secondary stack. Otherwise, the object must be allocated in - -- a storage pool. We generate an if statement to test the - -- implicit allocation formal and initialize a local access - -- value appropriately, creating allocators in the secondary - -- stack and global heap cases. The special formal also exists - -- and must be tested when the function has a tagged result, - -- even when the result subtype is constrained, because in - -- general such functions can be called in dispatching contexts - -- and must be handled similarly to functions with a class-wide - -- result. - - if Needs_BIP_Alloc_Form (Func_Id) then - Obj_Alloc_Formal := - Build_In_Place_Formal (Func_Id, BIP_Alloc_Form); - - declare - Pool_Id : constant Entity_Id := - Make_Temporary (Loc, 'P'); - Alloc_Obj_Id : Entity_Id; - Alloc_Obj_Decl : Node_Id; - Alloc_If_Stmt : Node_Id; - Guard_Except : Node_Id; - Heap_Allocator : Node_Id; - Pool_Decl : Node_Id; - Pool_Allocator : Node_Id; - Ptr_Type_Decl : Node_Id; - Ref_Type : Entity_Id; - SS_Allocator : Node_Id; - - begin - -- Create an access type designating the function's - -- result subtype. - - Ref_Type := Make_Temporary (Loc, 'A'); - - Ptr_Type_Decl := - Make_Full_Type_Declaration (Loc, - Defining_Identifier => Ref_Type, - Type_Definition => - Make_Access_To_Object_Definition (Loc, - All_Present => True, - Subtype_Indication => - New_Occurrence_Of (Ret_Obj_Typ, Loc))); - - Insert_Before (Ret_Obj_Decl, Ptr_Type_Decl); - - -- Create an access object that will be initialized to an - -- access value denoting the return object, either coming - -- from an implicit access value passed in by the caller - -- or from the result of an allocator. - - Alloc_Obj_Id := Make_Temporary (Loc, 'R'); - Set_Etype (Alloc_Obj_Id, Ref_Type); - - Alloc_Obj_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Alloc_Obj_Id, - Object_Definition => - New_Occurrence_Of (Ref_Type, Loc)); - - Insert_Before (Ret_Obj_Decl, Alloc_Obj_Decl); - - -- Create allocators for both the secondary stack and - -- global heap. If there's an initialization expression, - -- then create these as initialized allocators. - - if Present (Ret_Obj_Expr) - and then not No_Initialization (Ret_Obj_Decl) - then - -- Always use the type of the expression for the - -- qualified expression, rather than the result type. - -- In general we cannot always use the result type - -- for the allocator, because the expression might be - -- of a specific type, such as in the case of an - -- aggregate or even a nonlimited object when the - -- result type is a limited class-wide interface type. - - Heap_Allocator := - Make_Allocator (Loc, - Expression => - Make_Qualified_Expression (Loc, - Subtype_Mark => - New_Occurrence_Of - (Etype (Ret_Obj_Expr), Loc), - Expression => - New_Copy_Tree - (Source => Ret_Obj_Expr, - Scopes_In_EWA_OK => True))); - - else - -- If the function returns a class-wide type we cannot - -- use the return type for the allocator. Instead we - -- use the type of the expression, which must be an - -- aggregate of a definite type. - - if Is_Class_Wide_Type (Ret_Obj_Typ) then - Heap_Allocator := - Make_Allocator (Loc, - Expression => - New_Occurrence_Of - (Etype (Ret_Obj_Expr), Loc)); - else - Heap_Allocator := - Make_Allocator (Loc, - Expression => - New_Occurrence_Of (Ret_Obj_Typ, Loc)); - end if; - - -- If the object requires default initialization then - -- that will happen later following the elaboration of - -- the object renaming. If we don't turn it off here - -- then the object will be default initialized twice. - - Set_No_Initialization (Heap_Allocator); - end if; - - -- Set the flag indicating that the allocator came from - -- a build-in-place return statement, so we can avoid - -- adjusting the allocated object. Note that this flag - -- will be inherited by the copies made below. - - Set_Alloc_For_BIP_Return (Heap_Allocator); - - -- The Pool_Allocator is just like the Heap_Allocator, - -- except we set Storage_Pool and Procedure_To_Call so - -- it will use the user-defined storage pool. - - Pool_Allocator := - New_Copy_Tree - (Source => Heap_Allocator, - Scopes_In_EWA_OK => True); - - pragma Assert (Alloc_For_BIP_Return (Pool_Allocator)); - - -- Do not generate the renaming of the build-in-place - -- pool parameter on ZFP because the parameter is not - -- created in the first place. - - if RTE_Available (RE_Root_Storage_Pool_Ptr) then - Pool_Decl := - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Pool_Id, - Subtype_Mark => - New_Occurrence_Of - (RTE (RE_Root_Storage_Pool), Loc), - Name => - Make_Explicit_Dereference (Loc, - New_Occurrence_Of - (Build_In_Place_Formal - (Func_Id, BIP_Storage_Pool), Loc))); - Set_Storage_Pool (Pool_Allocator, Pool_Id); - Set_Procedure_To_Call - (Pool_Allocator, RTE (RE_Allocate_Any)); - else - Pool_Decl := Make_Null_Statement (Loc); - end if; - - -- If the No_Allocators restriction is active, then only - -- an allocator for secondary stack allocation is needed. - -- It's OK for such allocators to have Comes_From_Source - -- set to False, because gigi knows not to flag them as - -- being a violation of No_Implicit_Heap_Allocations. - - if Restriction_Active (No_Allocators) then - SS_Allocator := Heap_Allocator; - Heap_Allocator := Make_Null (Loc); - Pool_Allocator := Make_Null (Loc); - - -- Otherwise the heap and pool allocators may be needed, - -- so we make another allocator for secondary stack - -- allocation. - - else - SS_Allocator := - New_Copy_Tree - (Source => Heap_Allocator, - Scopes_In_EWA_OK => True); - - pragma Assert (Alloc_For_BIP_Return (SS_Allocator)); - - -- The heap and pool allocators are marked as - -- Comes_From_Source since they correspond to an - -- explicit user-written allocator (that is, it will - -- only be executed on behalf of callers that call the - -- function as initialization for such an allocator). - -- Prevents errors when No_Implicit_Heap_Allocations - -- is in force. - - Set_Comes_From_Source (Heap_Allocator, True); - Set_Comes_From_Source (Pool_Allocator, True); - end if; - - -- The allocator is returned on the secondary stack - - Check_Restriction (No_Secondary_Stack, N); - Set_Storage_Pool (SS_Allocator, RTE (RE_SS_Pool)); - Set_Procedure_To_Call - (SS_Allocator, RTE (RE_SS_Allocate)); - - -- The allocator is returned on the secondary stack, - -- so indicate that the function return, as well as - -- all blocks that encloses the allocator, must not - -- release it. The flags must be set now because - -- the decision to use the secondary stack is done - -- very late in the course of expanding the return - -- statement, past the point where these flags are - -- normally set. - - Set_Uses_Sec_Stack (Func_Id); - Set_Uses_Sec_Stack (Return_Statement_Entity (N)); - Set_Sec_Stack_Needed_For_Return - (Return_Statement_Entity (N)); - Set_Enclosing_Sec_Stack_Return (N); - - -- Guard against poor expansion on the caller side by - -- using a raise statement to catch out-of-range values - -- of formal parameter BIP_Alloc_Form. - - if Exceptions_OK then - Guard_Except := - Make_Raise_Program_Error (Loc, - Reason => PE_Build_In_Place_Mismatch); - else - Guard_Except := Make_Null_Statement (Loc); - end if; - - -- Create an if statement to test the BIP_Alloc_Form - -- formal and initialize the access object to either the - -- BIP_Object_Access formal (BIP_Alloc_Form = - -- Caller_Allocation), the result of allocating the - -- object in the secondary stack (BIP_Alloc_Form = - -- Secondary_Stack), or else an allocator to create the - -- return object in the heap or user-defined pool - -- (BIP_Alloc_Form = Global_Heap or User_Storage_Pool). - - -- ??? An unchecked type conversion must be made in the - -- case of assigning the access object formal to the - -- local access object, because a normal conversion would - -- be illegal in some cases (such as converting access- - -- to-unconstrained to access-to-constrained), but the - -- the unchecked conversion will presumably fail to work - -- right in just such cases. It's not clear at all how to - -- handle this. ??? - - Alloc_If_Stmt := - Make_If_Statement (Loc, - Condition => - Make_Op_Eq (Loc, - Left_Opnd => - New_Occurrence_Of (Obj_Alloc_Formal, Loc), - Right_Opnd => - Make_Integer_Literal (Loc, - UI_From_Int (BIP_Allocation_Form'Pos - (Caller_Allocation)))), - - Then_Statements => New_List ( - Make_Assignment_Statement (Loc, - Name => - New_Occurrence_Of (Alloc_Obj_Id, Loc), - Expression => - Unchecked_Convert_To - (Ref_Type, - New_Occurrence_Of (Obj_Acc_Formal, Loc)))), - - Elsif_Parts => New_List ( - Make_Elsif_Part (Loc, - Condition => - Make_Op_Eq (Loc, - Left_Opnd => - New_Occurrence_Of (Obj_Alloc_Formal, Loc), - Right_Opnd => - Make_Integer_Literal (Loc, - UI_From_Int (BIP_Allocation_Form'Pos - (Secondary_Stack)))), - - Then_Statements => New_List ( - Make_Assignment_Statement (Loc, - Name => - New_Occurrence_Of (Alloc_Obj_Id, Loc), - Expression => SS_Allocator))), - - Make_Elsif_Part (Loc, - Condition => - Make_Op_Eq (Loc, - Left_Opnd => - New_Occurrence_Of (Obj_Alloc_Formal, Loc), - Right_Opnd => - Make_Integer_Literal (Loc, - UI_From_Int (BIP_Allocation_Form'Pos - (Global_Heap)))), - - Then_Statements => New_List ( - Build_Heap_Or_Pool_Allocator - (Temp_Id => Alloc_Obj_Id, - Temp_Typ => Ref_Type, - Func_Id => Func_Id, - Ret_Typ => Ret_Obj_Typ, - Alloc_Expr => Heap_Allocator))), - - -- ???If all is well, we can put the following - -- 'elsif' in the 'else', but this is a useful - -- self-check in case caller and callee don't agree - -- on whether BIPAlloc and so on should be passed. - - Make_Elsif_Part (Loc, - Condition => - Make_Op_Eq (Loc, - Left_Opnd => - New_Occurrence_Of (Obj_Alloc_Formal, Loc), - Right_Opnd => - Make_Integer_Literal (Loc, - UI_From_Int (BIP_Allocation_Form'Pos - (User_Storage_Pool)))), - - Then_Statements => New_List ( - Pool_Decl, - Build_Heap_Or_Pool_Allocator - (Temp_Id => Alloc_Obj_Id, - Temp_Typ => Ref_Type, - Func_Id => Func_Id, - Ret_Typ => Ret_Obj_Typ, - Alloc_Expr => Pool_Allocator)))), - - -- Raise Program_Error if it's none of the above; - -- this is a compiler bug. - - Else_Statements => New_List (Guard_Except)); - - -- If a separate initialization assignment was created - -- earlier, append that following the assignment of the - -- implicit access formal to the access object, to ensure - -- that the return object is initialized in that case. In - -- this situation, the target of the assignment must be - -- rewritten to denote a dereference of the access to the - -- return object passed in by the caller. - - if Present (Init_Assignment) then - Rewrite (Name (Init_Assignment), - Make_Explicit_Dereference (Loc, - Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc))); - pragma Assert - (Assignment_OK - (Original_Node (Name (Init_Assignment)))); - Set_Assignment_OK (Name (Init_Assignment)); - - Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id)); - - Append_To - (Then_Statements (Alloc_If_Stmt), Init_Assignment); - end if; - - Insert_Before (Ret_Obj_Decl, Alloc_If_Stmt); - - -- Remember the local access object for use in the - -- dereference of the renaming created below. - - Obj_Acc_Formal := Alloc_Obj_Id; - end; - - -- When the function's subtype is unconstrained and a run-time - -- test is not needed, we nevertheless need to build the return - -- using the function's result subtype. - - elsif not Is_Constrained (Underlying_Type (Etype (Func_Id))) - then - declare - Alloc_Obj_Id : Entity_Id; - Alloc_Obj_Decl : Node_Id; - Ptr_Type_Decl : Node_Id; - Ref_Type : Entity_Id; - - begin - -- Create an access type designating the function's - -- result subtype. - - Ref_Type := Make_Temporary (Loc, 'A'); - - Ptr_Type_Decl := - Make_Full_Type_Declaration (Loc, - Defining_Identifier => Ref_Type, - Type_Definition => - Make_Access_To_Object_Definition (Loc, - All_Present => True, - Subtype_Indication => - New_Occurrence_Of (Ret_Obj_Typ, Loc))); - - Insert_Before (Ret_Obj_Decl, Ptr_Type_Decl); - - -- Create an access object initialized to the conversion - -- of the implicit access value passed in by the caller. - - Alloc_Obj_Id := Make_Temporary (Loc, 'R'); - Set_Etype (Alloc_Obj_Id, Ref_Type); - - -- See the ??? comment a few lines above about the use of - -- an unchecked conversion here. - - Alloc_Obj_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Alloc_Obj_Id, - Object_Definition => - New_Occurrence_Of (Ref_Type, Loc), - Expression => - Unchecked_Convert_To - (Ref_Type, - New_Occurrence_Of (Obj_Acc_Formal, Loc))); - - Insert_Before (Ret_Obj_Decl, Alloc_Obj_Decl); - - -- Remember the local access object for use in the - -- dereference of the renaming created below. - - Obj_Acc_Formal := Alloc_Obj_Id; - end; - end if; - - -- Replace the return object declaration with a renaming of a - -- dereference of the access value designating the return - -- object. - - Obj_Acc_Deref := - Make_Explicit_Dereference (Loc, - Prefix => New_Occurrence_Of (Obj_Acc_Formal, Loc)); - - Rewrite (Ret_Obj_Decl, - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Ret_Obj_Id, - Access_Definition => Empty, - Subtype_Mark => New_Occurrence_Of (Ret_Obj_Typ, Loc), - Name => Obj_Acc_Deref)); + -- Build a simple_return_statement that returns the return object - Set_Renamed_Object (Ret_Obj_Id, Obj_Acc_Deref); - end; - end if; + Return_Stmt := + Make_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (Ret_Obj_Id, Loc)); + Append_To (Stmts, Return_Stmt); -- Case where we do not need to build a block. But we're about to drop -- Return_Object_Declarations on the floor, so assert that it contains @@ -6124,9 +5349,7 @@ package body Exp_Ch6 is -- before an object is returned. A predicate that applies to the return -- subtype is checked immediately before an object is returned. - -- Suppress access checks to avoid generating extra checks for b-i-p. - - Analyze (N, Suppress => Access_Check); + Analyze (N); end Expand_N_Extended_Return_Statement; ---------------------------- @@ -8518,26 +7741,6 @@ package body Exp_Ch6 is end if; end Install_Class_Preconditions_Check; - ----------------------------------- - -- Is_Build_In_Place_Result_Type -- - ----------------------------------- - - function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean is - begin - if not Expander_Active then - return False; - end if; - - -- In Ada 2005 all functions with an inherently limited return type - -- must be handled using a build-in-place profile, including the case - -- of a function with a limited interface result, where the function - -- may return objects of nonlimited descendants. - - return Is_Limited_View (Typ) - and then Ada_Version >= Ada_2005 - and then not Debug_Flag_Dot_L; - end Is_Build_In_Place_Result_Type; - ------------------------------ -- Is_Build_In_Place_Entity -- ------------------------------ @@ -8655,6 +7858,36 @@ package body Exp_Ch6 is end; end Is_Build_In_Place_Function_Call; + ----------------------------------- + -- Is_Build_In_Place_Result_Type -- + ----------------------------------- + + function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean is + begin + if not Expander_Active then + return False; + end if; + + -- In Ada 2005 all functions with an inherently limited return type + -- must be handled using a build-in-place profile, including the case + -- of a function with a limited interface result, where the function + -- may return objects of nonlimited descendants. + + return Is_Limited_View (Typ) + and then Ada_Version >= Ada_2005 + and then not Debug_Flag_Dot_L; + end Is_Build_In_Place_Result_Type; + + ------------------------------------- + -- Is_Build_In_Place_Return_Object -- + ------------------------------------- + + function Is_Build_In_Place_Return_Object (E : Entity_Id) return Boolean is + begin + return Is_Return_Object (E) + and then Is_Build_In_Place_Function (Return_Applies_To (Scope (E))); + end Is_Build_In_Place_Return_Object; + ----------------------- -- Is_Null_Procedure -- ----------------------- diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index f886eda..19d0bc3 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -127,22 +127,6 @@ package Exp_Ch6 is function Is_Build_In_Place_Entity (E : Entity_Id) return Boolean; -- Ada 2005 (AI-318-02): Returns True if E is a BIP entity. - function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean; - -- Ada 2005 (AI-318-02): Returns True if functions returning the type use - -- build-in-place protocols. For inherently limited types, this must be - -- True in >= Ada 2005, and must be False in Ada 95. For other types, it - -- can be True or False, and the decision should be based on efficiency, - -- and should be the same for all language versions, so that mixed-dialect - -- programs will work. - -- - -- For inherently limited types in Ada 2005, True means that calls will - -- actually be build-in-place in all cases. For other types, build-in-place - -- will be used when possible, but we need to make a copy in some - -- cases. For example, for "X := F(...);" if F can see X, or if F can - -- propagate exceptions, we need to store its result in a temp in general, - -- and copy the temp into X. Also, for "return Global_Var;" Global_Var - -- needs to be copied into the function result object. - function Is_Build_In_Place_Function (E : Entity_Id) return Boolean; -- Ada 2005 (AI-318-02): Returns True if E denotes a function, generic -- function, or access-to-function type for which @@ -155,6 +139,15 @@ package Exp_Ch6 is -- that requires handling as a build-in-place call (possibly qualified or -- converted). + function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean; + -- Ada 2005 (AI-318-02): Returns True if functions returning the type use + -- build-in-place protocols. For inherently limited types, this must be + -- True in >= Ada 2005 and must be False in Ada 95. + + function Is_Build_In_Place_Return_Object (E : Entity_Id) return Boolean; + -- Ada 2005 (AI-318-02): Return True is E is a return object of a function + -- that uses build-in-place protocols. + function Is_Null_Procedure (Subp : Entity_Id) return Boolean; -- Predicate to recognize stubbed procedures and null procedures, which -- can be inlined unconditionally in all cases. @@ -272,4 +265,7 @@ package Exp_Ch6 is -- to reference the secondary dispatch table of an interface; otherwise -- return Empty. +private + pragma Inline (Is_Build_In_Place_Return_Object); + end Exp_Ch6; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 2be891e..0766482 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -441,10 +441,6 @@ package body Exp_Ch7 is -- of the formal of Proc, or force a conversion to the class-wide type in -- the case where the operation is abstract. - function Enclosing_Function (E : Entity_Id) return Entity_Id; - -- Given an arbitrary entity, traverse the scope chain looking for the - -- first enclosing function. Return Empty if no function was found. - function Make_Call (Loc : Source_Ptr; Proc_Id : Entity_Id; @@ -3431,7 +3427,9 @@ package body Exp_Ch7 is if Is_Return_Object (Obj_Id) then declare - Func_Id : constant Entity_Id := Enclosing_Function (Obj_Id); + Func_Id : constant Entity_Id := + Return_Applies_To (Scope (Obj_Id)); + begin if Is_Build_In_Place_Function (Func_Id) and then Needs_BIP_Finalization_Master (Func_Id) @@ -5084,26 +5082,6 @@ package body Exp_Ch7 is end if; end Convert_View; - ------------------------ - -- Enclosing_Function -- - ------------------------ - - function Enclosing_Function (E : Entity_Id) return Entity_Id is - Func_Id : Entity_Id; - - begin - Func_Id := E; - while Present (Func_Id) and then Func_Id /= Standard_Standard loop - if Ekind (Func_Id) = E_Function then - return Func_Id; - end if; - - Func_Id := Scope (Func_Id); - end loop; - - return Empty; - end Enclosing_Function; - ------------------------------- -- Establish_Transient_Scope -- ------------------------------- diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 93aa2ca..29969b3 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -4043,7 +4043,6 @@ package body Sem_Ch3 is Prev_Entity : Entity_Id := Empty; Related_Id : Entity_Id; - Full_View_Present : Boolean := False; -- Start of processing for Analyze_Object_Declaration @@ -4732,28 +4731,32 @@ package body Sem_Ch3 is Act_T := Find_Type_Of_Object (Object_Definition (N), N); end if; - -- Propagate attributes to full view when needed + if Act_T /= T then + declare + Full_View_Present : constant Boolean := + Is_Private_Type (Act_T) + and then Present (Full_View (Act_T)); + -- Propagate attributes to full view when needed - Set_Is_Constr_Subt_For_U_Nominal (Act_T); + begin + Set_Is_Constr_Subt_For_U_Nominal (Act_T); - if Is_Private_Type (Act_T) and then Present (Full_View (Act_T)) - then - Full_View_Present := True; - end if; + if Full_View_Present then + Set_Is_Constr_Subt_For_U_Nominal (Full_View (Act_T)); + end if; - if Full_View_Present then - Set_Is_Constr_Subt_For_U_Nominal (Full_View (Act_T)); - end if; + if Aliased_Present (N) then + Set_Is_Constr_Subt_For_UN_Aliased (Act_T); - if Aliased_Present (N) then - Set_Is_Constr_Subt_For_UN_Aliased (Act_T); + if Full_View_Present then + Set_Is_Constr_Subt_For_UN_Aliased (Full_View (Act_T)); + end if; + end if; - if Full_View_Present then - Set_Is_Constr_Subt_For_UN_Aliased (Full_View (Act_T)); - end if; + Freeze_Before (N, Act_T); + end; end if; - Freeze_Before (N, Act_T); Freeze_Before (N, T); end if; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 05db793..e5c13ed 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -34,7 +34,6 @@ with Einfo.Utils; use Einfo.Utils; with Elists; use Elists; with Errout; use Errout; with Expander; use Expander; -with Exp_Ch3; use Exp_Ch3; with Exp_Ch6; use Exp_Ch6; with Exp_Ch9; use Exp_Ch9; with Exp_Dbug; use Exp_Dbug; @@ -1520,33 +1519,7 @@ package body Sem_Ch6 is -- object declaration. Set_Is_Return_Object (Defining_Identifier (Obj_Decl)); - - -- Returning a build-in-place unconstrained array type we defer - -- the full analysis of the returned object to avoid generating - -- the corresponding constrained subtype; otherwise the bounds - -- would be created in the stack and a dangling reference would - -- be returned pointing to the bounds. We perform its preanalysis - -- to report errors on the initializing aggregate now (if any); - -- we also ensure its activation chain and Master variable are - -- defined (if tasks are being declared) since they are generated - -- as part of the analysis and expansion of the object declaration - -- at this stage. - - if Is_Array_Type (R_Type) - and then not Is_Constrained (R_Type) - and then Is_Build_In_Place_Function (Scope_Id) - and then Needs_BIP_Alloc_Form (Scope_Id) - and then Nkind (Expr) in N_Aggregate | N_Extension_Aggregate - then - Preanalyze (Obj_Decl); - - if Expander_Active then - Ensure_Activation_Chain_And_Master (Obj_Decl); - end if; - - else - Analyze (Obj_Decl); - end if; + Analyze (Obj_Decl); Check_Return_Subtype_Indication (Obj_Decl); @@ -9274,7 +9247,9 @@ package body Sem_Ch6 is -- Force the definition of the Itype in case of internal function -- calls within the same or nested scope. - if Is_Subprogram_Or_Generic_Subprogram (E) then + if Is_Subprogram_Or_Generic_Subprogram (E) + and then not Is_Compilation_Unit (E) + then Subp_Decl := Parent (E); -- The insertion point for an Itype reference should be after |