From 7b2aafc959f1ef24f111eb0d56b393bb2d315bbf Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Tue, 20 Dec 2011 13:41:00 +0000 Subject: [PATCH] sem_res.adb (Resolve_Allocator): Warning on allocation of tasks on a subpool and rewrite the allocator into a... 2011-12-20 Hristian Kirtchev * sem_res.adb (Resolve_Allocator): Warning on allocation of tasks on a subpool and rewrite the allocator into a raise Program_Error statement. * s-stposu.ads, s-stposu.adb: Code reformatting. (Create_Subpool): Remove formal parameter Storage_Size. (Default_Subpool_For_Pool): Add the default implementation of this routine. (Set_Pool_Of_Subpool): Rename formal parameter Pool to To. Update all the uses of the parameter. From-SVN: r182533 --- gcc/ada/ChangeLog | 12 ++++++++++++ gcc/ada/s-stposu.adb | 24 +++++++++++++++++++----- gcc/ada/s-stposu.ads | 44 ++++++++++++++++++++------------------------ gcc/ada/sem_res.adb | 21 ++++++++++++--------- 4 files changed, 63 insertions(+), 38 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1ddb5bb1f15..74d730914a2 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,15 @@ +2011-12-20 Hristian Kirtchev + + * sem_res.adb (Resolve_Allocator): Warning on allocation + of tasks on a subpool and rewrite the allocator into a raise + Program_Error statement. + * s-stposu.ads, s-stposu.adb: Code reformatting. + (Create_Subpool): Remove formal parameter Storage_Size. + (Default_Subpool_For_Pool): Add the default implementation of this + routine. + (Set_Pool_Of_Subpool): Rename formal parameter Pool to To. Update + all the uses of the parameter. + 2011-12-20 Rainer Orth * gcc-interface/Makefile.in (%86 linux%): diff --git a/gcc/ada/s-stposu.adb b/gcc/ada/s-stposu.adb index 78958412ab2..53f65cb2f37 100644 --- a/gcc/ada/s-stposu.adb +++ b/gcc/ada/s-stposu.adb @@ -431,6 +431,19 @@ package body System.Storage_Pools.Subpools is Deallocate (Pool, N_Addr, N_Size, Alignment); end Deallocate_Any_Controlled; + ------------------------------ + -- Default_Subpool_For_Pool -- + ------------------------------ + + function Default_Subpool_For_Pool + (Pool : Root_Storage_Pool_With_Subpools) return not null Subpool_Handle + is + begin + raise Program_Error; + + return Pool.Subpools.Subpool; + end Default_Subpool_For_Pool; + ------------ -- Detach -- ------------ @@ -607,7 +620,8 @@ package body System.Storage_Pools.Subpools is --------------------- function Pool_Of_Subpool (Subpool : not null Subpool_Handle) - return access Root_Storage_Pool_With_Subpools'Class is + return access Root_Storage_Pool_With_Subpools'Class + is begin return Subpool.Owner; end Pool_Of_Subpool; @@ -762,7 +776,7 @@ package body System.Storage_Pools.Subpools is procedure Set_Pool_Of_Subpool (Subpool : not null Subpool_Handle; - Pool : in out Root_Storage_Pool_With_Subpools'Class) + To : in out Root_Storage_Pool_With_Subpools'Class) is N_Ptr : SP_Node_Ptr; @@ -777,12 +791,12 @@ package body System.Storage_Pools.Subpools is -- Prevent the creation of a new subpool while the owner is being -- finalized. This is a serious error. - if Pool.Finalization_Started then + if To.Finalization_Started then raise Program_Error with "subpool creation after finalization started"; end if; - Subpool.Owner := Pool'Unchecked_Access; + Subpool.Owner := To'Unchecked_Access; -- Create a subpool node and decorate it. Since this node is not -- allocated on the owner's pool, it must be explicitly destroyed by @@ -792,7 +806,7 @@ package body System.Storage_Pools.Subpools is N_Ptr.Subpool := Subpool; Subpool.Node := N_Ptr; - Attach (N_Ptr, Pool.Subpools'Unchecked_Access); + Attach (N_Ptr, To.Subpools'Unchecked_Access); -- Mark the subpool's master as being a heterogeneous collection of -- controlled objects. diff --git a/gcc/ada/s-stposu.ads b/gcc/ada/s-stposu.ads index 38f8cfc73a3..d5819caa127 100644 --- a/gcc/ada/s-stposu.ads +++ b/gcc/ada/s-stposu.ads @@ -38,7 +38,7 @@ with System.Finalization_Masters; with System.Storage_Elements; package System.Storage_Pools.Subpools is - pragma Preelaborate; + pragma Preelaborate (Subpools); type Root_Storage_Pool_With_Subpools is abstract new Root_Storage_Pool with private; @@ -70,21 +70,16 @@ package System.Storage_Pools.Subpools is Storage_Address : out System.Address; Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; Alignment : System.Storage_Elements.Storage_Count; - Subpool : not null Subpool_Handle) - is abstract; + Subpool : not null Subpool_Handle) is abstract; -- ??? This precondition causes errors in simple tests, disabled for now --- with Pre'Class => Pool_Of_Subpool (Subpool) = Pool'Access; +-- with Pre'Class => Pool_Of_Subpool (Subpool) = Pool'Access; -- This routine requires implementation. Allocate an object described by -- Size_In_Storage_Elements and Alignment on a subpool. - function Create_Subpool - (Pool : in out Root_Storage_Pool_With_Subpools; - Storage_Size : Storage_Elements.Storage_Count := - Storage_Elements.Storage_Count'Last) - return not null Subpool_Handle - is abstract; + function Create_Subpool (Pool : in out Root_Storage_Pool_With_Subpools) + return not null Subpool_Handle is abstract; -- This routine requires implementation. Create a subpool within the given -- pool_with_subpools. @@ -93,39 +88,40 @@ package System.Storage_Pools.Subpools is Storage_Address : System.Address; Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; Alignment : System.Storage_Elements.Storage_Count) - is null; + is null; procedure Deallocate_Subpool (Pool : in out Root_Storage_Pool_With_Subpools; - Subpool : in out Subpool_Handle) - is abstract; + Subpool : in out Subpool_Handle) is abstract; -- ??? This precondition causes errors in simple tests, disabled for now --- with Pre'Class => Pool_Of_Subpool (Subpool) = Pool'Access; +-- with Pre'Class => Pool_Of_Subpool (Subpool) = Pool'Access; -- This routine requires implementation. Reclaim the storage a particular -- subpool occupies in a pool_with_subpools. This routine is called by -- Ada.Unchecked_Deallocate_Subpool. function Default_Subpool_For_Pool - (Pool : Root_Storage_Pool_With_Subpools) - return not null Subpool_Handle - is abstract; - -- This routine requires implementation. Returns a common subpool used for - -- allocations without Subpool_Handle_name in the allocator. - - function Pool_Of_Subpool - (Subpool : not null Subpool_Handle) - return access Root_Storage_Pool_With_Subpools'Class; + (Pool : Root_Storage_Pool_With_Subpools) return not null Subpool_Handle; + -- Return a common subpool which is used for object allocations without a + -- Subpool_Handle_name in the allocator. The default implementation of this + -- routine raises Program_Error. + + function Pool_Of_Subpool (Subpool : not null Subpool_Handle) + return access Root_Storage_Pool_With_Subpools'Class; -- Return the owner of the subpool procedure Set_Pool_Of_Subpool (Subpool : not null Subpool_Handle; - Pool : in out Root_Storage_Pool_With_Subpools'Class); + To : in out Root_Storage_Pool_With_Subpools'Class); -- Set the owner of the subpool. This is intended to be called from -- Create_Subpool or similar subpool constructors. Raises Program_Error -- if the subpool already belongs to a pool. + overriding function Storage_Size (Pool : Root_Storage_Pool_With_Subpools) + return System.Storage_Elements.Storage_Count is + (System.Storage_Elements.Storage_Count'Last); + private -- Model -- Pool_With_Subpools SP_Node SP_Node SP_Node diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 55a5e365904..3a8d7d7357e 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -4469,23 +4469,26 @@ package body Sem_Res is and then Ekind (Current_Scope) = E_Package and then not In_Package_Body (Current_Scope) then - Error_Msg_N ("cannot activate task before body seen?", N); - Error_Msg_N ("\Program_Error will be raised at run time?", N); + Error_Msg_N ("?cannot activate task before body seen", N); + Error_Msg_N ("\?Program_Error will be raised at run time", N); end if; - -- Ada 2012 (AI05-0111-3): Issue a warning whenever allocating a task - -- or a type containing tasks on a subpool since the deallocation of - -- the subpool may lead to undefined task behavior. Perform the check - -- only when the allocator has not been converted into a Program_Error - -- due to a previous error. + -- Ada 2012 (AI05-0111-3): Detect an attempt to allocate a task or a + -- type with a task component on a subpool. This action must raise + -- Program_Error at runtime. if Ada_Version >= Ada_2012 and then Nkind (N) = N_Allocator and then Present (Subpool_Handle_Name (N)) and then Has_Task (Desig_T) then - Error_Msg_N ("?allocation of task on subpool may lead to " & - "undefined behavior", N); + Error_Msg_N ("?cannot allocate task on subpool", N); + Error_Msg_N ("\?Program_Error will be raised at run time", N); + + Rewrite (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Explicit_Raise)); + Set_Etype (N, Typ); end if; end Resolve_Allocator; -- 2.30.2