From 72fb810db9de1e8abdabefdb524567ad2691568e Mon Sep 17 00:00:00 2001 From: Jose Ruiz Date: Wed, 6 Jun 2007 12:46:22 +0200 Subject: [PATCH] s-taprob.adb (Unlock): Change the ceiling priority of the underlying lock, if needed. 2007-04-20 Jose Ruiz Arnaud Charlet * s-taprob.adb (Unlock): Change the ceiling priority of the underlying lock, if needed. * s-taprop.ads (Set_Ceiling): Add this procedure to change the ceiling priority associated to a lock. * s-tpoben.adb ([Vulnerable_]Complete_Task, Lock_Entries): Relax assertion to take into account case of no abort restriction. (Initialize_Protection_Entries): Add initialization for the field New_Ceiling associated to the protected object. (Unlock_Entries): Change the ceiling priority of the underlying lock, if needed. * s-solita.adb (Get_Current_Excep): Moved back to s-tasini/s-tarest, since this function needs to be set consistently with Update_Exception. * s-tarest.adb (Get_Current_Excep): Moved back to s-tasini/s-tarest, since this function needs to be set consistently with Update_Exception. * s-taskin.ads: Update comments on Interrupt_Server_Blocked_On_Event_Flag. (Unbind_Handler): Fix handling of server_task wakeup (Server_Task): Set self's state so that Unbind_Handler can take appropriate actions. (Common_ATCB): Now use a constant from System.Parameters to determine the max size of the Task_Image field. * s-tassta.adb (Task_Wrapper): Now pass the overflow guard to the Initialize_Analyzer function. ([Vulnerable_]Complete_Task, Lock_Entries): Relax assertion to take into account case of no abort restriction. ([Vulnerable_]Complete_Master): Modify assertion. * s-tataat.adb (Finalize): Use the nestable versions of Defer/Undefer_Abort. * s-tpobop.adb (Protected_Entry_Call): Relax assertion. * s-tpobop.ads: Update comments. * s-tposen.adb (Protected_Single_Entry_Call): Call Lock_Entry instead of locking the object manually, to avoid inconsistencies between Lock/Unlock_Entry assertions. * s-interr.ads, s-interr.adb (Server_Task): Fix race condition when terminating application and System.Parameters.No_Abort is True. Update comments on Interrupt_Server_Blocked_On_Event_Flag. (Unbind_Handler): Fix handling of server_task wakeup (Server_Task): Set self's state so that Unbind_Handler can take appropriate actions. From-SVN: r125458 --- gcc/ada/s-interr.adb | 59 +++++++++++++++++++++++++++++------------ gcc/ada/s-interr.ads | 4 +-- gcc/ada/s-solita.adb | 9 ------- gcc/ada/s-taprob.adb | 20 ++++++++++++++ gcc/ada/s-taprop.ads | 63 ++++++++++++++++++++++++++++---------------- gcc/ada/s-tarest.adb | 19 ++++++++++--- gcc/ada/s-taskin.ads | 21 ++++++++------- gcc/ada/s-tassta.adb | 54 ++++++++++++++++++++++--------------- gcc/ada/s-tataat.adb | 20 +++++++++----- gcc/ada/s-tpoben.adb | 40 +++++++++++++++++++++------- gcc/ada/s-tpobop.adb | 15 ++++++----- gcc/ada/s-tpobop.ads | 8 +++--- gcc/ada/s-tposen.adb | 14 +++------- 13 files changed, 226 insertions(+), 120 deletions(-) diff --git a/gcc/ada/s-interr.adb b/gcc/ada/s-interr.adb index f4545fc96df..f5eb510558a 100644 --- a/gcc/ada/s-interr.adb +++ b/gcc/ada/s-interr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -120,7 +120,7 @@ with System.Tasking.Initialization; with System.Parameters; -- used for Single_Lock -with Unchecked_Conversion; +with Ada.Unchecked_Conversion; package body System.Interrupts is @@ -133,7 +133,7 @@ package body System.Interrupts is package IMNG renames System.Interrupt_Management; package IMOP renames System.Interrupt_Management.Operations; - function To_System is new Unchecked_Conversion + function To_System is new Ada.Unchecked_Conversion (Ada.Task_Identification.Task_Id, Task_Id); ----------------- @@ -220,16 +220,16 @@ package body System.Interrupts is -- Holds the task and entry index (if any) for each interrupt Blocked : array (Interrupt_ID'Range) of Boolean := (others => False); - pragma Volatile_Components (Blocked); + pragma Atomic_Components (Blocked); -- True iff the corresponding interrupt is blocked in the process level Ignored : array (Interrupt_ID'Range) of Boolean := (others => False); - pragma Volatile_Components (Ignored); + pragma Atomic_Components (Ignored); -- True iff the corresponding interrupt is blocked in the process level Last_Unblocker : array (Interrupt_ID'Range) of Task_Id := (others => Null_Task); - pragma Volatile_Components (Last_Unblocker); + pragma Atomic_Components (Last_Unblocker); -- Holds the ID of the last Task which Unblocked this Interrupt. -- It contains Null_Task if no tasks have ever requested the -- Unblocking operation or the Interrupt is currently Blocked. @@ -567,7 +567,7 @@ package body System.Interrupts is Handler_Addr : System.Address; end record; - function To_Fat_Ptr is new Unchecked_Conversion + function To_Fat_Ptr is new Ada.Unchecked_Conversion (Parameterless_Handler, Fat_Ptr); Ptr : R_Link; @@ -762,25 +762,41 @@ package body System.Interrupts is -------------------- procedure Unbind_Handler (Interrupt : Interrupt_ID) is + Server : System.Tasking.Task_Id; begin if not Blocked (Interrupt) then - -- Currently, there is a Handler or an Entry attached and -- corresponding Server_Task is waiting on "sigwait." -- We have to wake up the Server_Task and make it -- wait on condition variable by sending an -- Abort_Task_Interrupt - POP.Abort_Task (Server_ID (Interrupt)); + Server := Server_ID (Interrupt); - -- Make sure corresponding Server_Task is out of its own - -- sigwait state. + case Server.Common.State is + when Interrupt_Server_Idle_Sleep | + Interrupt_Server_Blocked_Interrupt_Sleep + => + POP.Wakeup (Server, Server.Common.State); - Ret_Interrupt := - Interrupt_ID (IMOP.Interrupt_Wait (Intwait_Mask'Access)); + when Interrupt_Server_Blocked_On_Event_Flag => + POP.Abort_Task (Server); + + -- Make sure corresponding Server_Task is out of its + -- own sigwait state. - pragma Assert - (Ret_Interrupt = Interrupt_ID (IMNG.Abort_Task_Interrupt)); + Ret_Interrupt := + Interrupt_ID (IMOP.Interrupt_Wait (Intwait_Mask'Access)); + pragma Assert + (Ret_Interrupt = Interrupt_ID (IMNG.Abort_Task_Interrupt)); + + when Runnable => + null; + + when others => + pragma Assert (False); + null; + end case; IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt)); @@ -1120,7 +1136,7 @@ package body System.Interrupts is IMOP.Thread_Block_Interrupt (IMNG.Interrupt_ID (Interrupt)); if User_Handler (Interrupt).H /= null - or else User_Entry (Interrupt).T /= Null_Task + or else User_Entry (Interrupt).T /= Null_Task then -- This is the case where the Server_Task is waiting -- on "sigwait." Wake it up by sending an @@ -1325,14 +1341,23 @@ package body System.Interrupts is -- from status change (Unblocked -> Blocked). If that is not -- the case, we should exceute the attached Procedure or Entry. + Self_ID.Common.State := Interrupt_Server_Blocked_On_Event_Flag; POP.Unlock (Self_ID); if Single_Lock then POP.Unlock_RTS; end if; + -- Avoid race condition when terminating application and + -- System.Parameters.No_Abort is True. + + if Parameters.No_Abort and then Self_ID.Pending_Action then + Initialization.Do_Pending_Action (Self_ID); + end if; + Ret_Interrupt := Interrupt_ID (IMOP.Interrupt_Wait (Intwait_Mask'Access)); + Self_ID.Common.State := Runnable; if Ret_Interrupt = Interrupt_ID (IMNG.Abort_Task_Interrupt) then @@ -1458,7 +1483,7 @@ begin -- process during the RTS start up. (See processing in s-inmaop.adb). Pass -- the Interrupt_Mask of the environment task to the Interrupt_Manager. - -- Note : At this point we know that all tasks are masked for non-reserved + -- Note: At this point we know that all tasks are masked for non-reserved -- signals. Only the Interrupt_Manager will have masks set up differently -- inheriting the original environment task's mask. diff --git a/gcc/ada/s-interr.ads b/gcc/ada/s-interr.ads index 3a92ef01ed4..6481fc2bd06 100644 --- a/gcc/ada/s-interr.ads +++ b/gcc/ada/s-interr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -209,7 +209,7 @@ package System.Interrupts is (Handler_Addr : System.Address); -- This routine should be called by the compiler to allow the handler be -- used as an Interrupt Handler. That means call this procedure for each - -- pragma Interrup_Handler providing the address of the handler (not + -- pragma Interrupt_Handler providing the address of the handler (not -- including the pointer to the actual PO, this way this routine is called -- only once for each type definition of PO). diff --git a/gcc/ada/s-solita.adb b/gcc/ada/s-solita.adb index 2bc27932632..62fd01b5011 100644 --- a/gcc/ada/s-solita.adb +++ b/gcc/ada/s-solita.adb @@ -85,9 +85,6 @@ package body System.Soft_Links.Tasking is procedure Set_Sec_Stack_Addr (Addr : Address); -- Get/Set location of current task's secondary stack - function Get_Current_Excep return SSL.EOA; - -- Task-safe version of SSL.Get_Current_Excep - procedure Timed_Delay_T (Time : Duration; Mode : Integer); -- Task-safe version of SSL.Timed_Delay @@ -98,11 +95,6 @@ package body System.Soft_Links.Tasking is -- Soft-Link Get Bodies -- -------------------------- - function Get_Current_Excep return SSL.EOA is - begin - return STPO.Self.Common.Compiler_Data.Current_Excep'Access; - end Get_Current_Excep; - function Get_Jmpbuf_Address return Address is begin return STPO.Self.Common.Compiler_Data.Jmpbuf_Address; @@ -217,7 +209,6 @@ package body System.Soft_Links.Tasking is SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access; SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access; SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access; - SSL.Get_Current_Excep := Get_Current_Excep'Access; SSL.Timed_Delay := Timed_Delay_T'Access; SSL.Task_Termination_Handler := Task_Termination_Handler_T'Access; diff --git a/gcc/ada/s-taprob.adb b/gcc/ada/s-taprob.adb index d4b08e4c1f1..603d9a268d7 100644 --- a/gcc/ada/s-taprob.adb +++ b/gcc/ada/s-taprob.adb @@ -40,6 +40,7 @@ with System.Task_Primitives.Operations; -- used for Write_Lock -- Unlock -- Self +-- Set_Ceiling with System.Parameters; -- used for Runtime_Traces @@ -55,6 +56,13 @@ package body System.Tasking.Protected_Objects is use System.Task_Primitives.Operations; use System.Traces; + ---------------- + -- Local Data -- + ---------------- + + Locking_Policy : Character; + pragma Import (C, Locking_Policy, "__gl_locking_policy"); + ------------------------- -- Finalize_Protection -- ------------------------- @@ -255,6 +263,18 @@ package body System.Tasking.Protected_Objects is end; end if; + -- Before releasing the mutex we must actually update its ceiling + -- priority if it has been changed. + + if Object.New_Ceiling /= Object.Ceiling then + if Locking_Policy = 'C' then + System.Task_Primitives.Operations.Set_Ceiling + (Object.L'Access, Object.New_Ceiling); + end if; + + Object.Ceiling := Object.New_Ceiling; + end if; + Unlock (Object.L'Access); if Parameters.Runtime_Traces then diff --git a/gcc/ada/s-taprop.ads b/gcc/ada/s-taprop.ads index aca25c3cd2f..79996b76567 100644 --- a/gcc/ada/s-taprop.ads +++ b/gcc/ada/s-taprop.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -138,11 +138,13 @@ package System.Task_Primitives.Operations is -- more details. procedure Initialize_Lock - (Prio : System.Any_Priority; L : not null access Lock); + (Prio : System.Any_Priority; + L : not null access Lock); procedure Initialize_Lock - (L : not null access RTS_Lock; Level : Lock_Level); + (L : not null access RTS_Lock; + Level : Lock_Level); pragma Inline (Initialize_Lock); - -- Initialize a lock object. + -- Initialize a lock object -- -- For Lock, Prio is the ceiling priority associated with the lock. For -- RTS_Lock, the ceiling is implicitly Priority'Last. @@ -158,9 +160,9 @@ package System.Task_Primitives.Operations is -- unless the lock object has been initialized and has not since been -- finalized. -- - -- Initialization of the per-task lock is implicit in Create_Task. + -- Initialization of the per-task lock is implicit in Create_Task -- - -- These operations raise Storage_Error if a lack of storage is detected. + -- These operations raise Storage_Error if a lack of storage is detected procedure Finalize_Lock (L : not null access Lock); procedure Finalize_Lock (L : not null access RTS_Lock); @@ -169,9 +171,11 @@ package System.Task_Primitives.Operations is -- corresponding Initialize_Lock operation. procedure Write_Lock - (L : not null access Lock; Ceiling_Violation : out Boolean); + (L : not null access Lock; + Ceiling_Violation : out Boolean); procedure Write_Lock - (L : not null access RTS_Lock; Global_Lock : Boolean := False); + (L : not null access RTS_Lock; + Global_Lock : Boolean := False); procedure Write_Lock (T : ST.Task_Id); pragma Inline (Write_Lock); @@ -198,7 +202,8 @@ package System.Task_Primitives.Operations is -- per-task lock is implicit in Exit_Task. procedure Read_Lock - (L : not null access Lock; Ceiling_Violation : out Boolean); + (L : not null access Lock; + Ceiling_Violation : out Boolean); pragma Inline (Read_Lock); -- Lock a lock object for read access. After this operation returns, -- the calling task has non-exclusive read permission for the logical @@ -223,11 +228,12 @@ package System.Task_Primitives.Operations is procedure Unlock (L : not null access Lock); procedure Unlock - (L : not null access RTS_Lock; Global_Lock : Boolean := False); + (L : not null access RTS_Lock; + Global_Lock : Boolean := False); procedure Unlock (T : ST.Task_Id); pragma Inline (Unlock); - -- Unlock a locked lock object. + -- Unlock a locked lock object -- -- The effect is undefined unless the calling task holds read or write -- permission for the lock L, and L is the lock object most recently @@ -251,12 +257,11 @@ package System.Task_Primitives.Operations is -- done at interrupt priority. In general, it is not acceptable to give -- all RTS locks interrupt priority, since that whould give terrible -- performance on systems where this has the effect of masking hardware - -- interrupts, though we could get away with allowing - -- Interrupt_Priority'last where we are layered on an OS that does not - -- allow us to mask interrupts. Ideally, we would like to raise - -- Program_Error back at the original point of the RTS call, but this - -- would require a lot of detailed analysis and recoding, with almost - -- certain performance penalties. + -- interrupts, though we could get away allowing Interrupt_Priority'last + -- where we are layered on an OS that does not allow us to mask interrupts. + -- Ideally, we would like to raise Program_Error back at the original point + -- of the RTS call, but this would require a lot of detailed analysis and + -- recoding, with almost certain performance penalties. -- For POSIX systems, we considered just skipping setting priority ceiling -- on RTS locks. This would mean there is no ceiling violation, but we @@ -286,6 +291,18 @@ package System.Task_Primitives.Operations is -- For now, we will just shut down the system if there is ceiling violation + procedure Set_Ceiling + (L : not null access Lock; + Prio : System.Any_Priority); + pragma Inline (Set_Ceiling); + -- Change the ceiling priority associated to the lock + -- + -- The effect is undefined unless the calling task holds read or write + -- permission for the lock L, and L is the lock object most recently + -- locked by the calling task for which the calling task still holds + -- read or write permission. (That is, matching pairs of Lock and Unlock + -- operations on each lock object must be properly nested.) + procedure Yield (Do_Yield : Boolean := True); pragma Inline (Yield); -- Yield the processor. Add the calling task to the tail of the ready @@ -326,15 +343,15 @@ package System.Task_Primitives.Operations is -- Extensions -- ---------------- - -- Whoever calls either of the Sleep routines is responsible - -- for checking for pending aborts before the call. - -- Pending priority changes are handled internally. + -- Whoever calls either of the Sleep routines is responsible for checking + -- for pending aborts before the call. Pending priority changes are handled + -- internally. procedure Sleep (Self_ID : ST.Task_Id; Reason : System.Tasking.Task_States); pragma Inline (Sleep); - -- Wait until the current task, T, is signaled to wake up. + -- Wait until the current task, T, is signaled to wake up -- -- precondition: -- The calling task is holding its own ATCB lock @@ -400,8 +417,8 @@ package System.Task_Primitives.Operations is -- setup/cleared upon entrance/exit of RTS while maintaining a single -- thread of control in the RTS. Since we intend these routines to be used -- for implementing the Single_Lock RTS, Lock_RTS should follow the first - -- Defer_Abortion operation entering RTS. In the same fashion Unlock_RTS - -- should preceed the last Undefer_Abortion exiting RTS. + -- Defer_Abort operation entering RTS. In the same fashion Unlock_RTS + -- should preceed the last Undefer_Abort exiting RTS. -- -- These routines also replace the functions Lock/Unlock_All_Tasks_List diff --git a/gcc/ada/s-tarest.adb b/gcc/ada/s-tarest.adb index ab64fa8d2c0..cfe07583539 100644 --- a/gcc/ada/s-tarest.adb +++ b/gcc/ada/s-tarest.adb @@ -93,6 +93,9 @@ package body System.Tasking.Restricted.Stages is -- Tasking versions of services needed by non-tasking programs -- ----------------------------------------------------------------- + function Get_Current_Excep return SSL.EOA; + -- Task-safe version of SSL.Get_Current_Excep + procedure Task_Lock; -- Locks out other tasks. Preceding a section of code by Task_Lock and -- following it by Task_Unlock creates a critical region. This is used @@ -126,6 +129,15 @@ package body System.Tasking.Restricted.Stages is -- installing tasking versions of certain operations used by the compiler. -- Init_RTS is called during elaboration. + ----------------------- + -- Get_Current_Excep -- + ----------------------- + + function Get_Current_Excep return SSL.EOA is + begin + return STPO.Self.Common.Compiler_Data.Current_Excep'Access; + end Get_Current_Excep; + --------------- -- Task_Lock -- --------------- @@ -616,9 +628,10 @@ package body System.Tasking.Restricted.Stages is -- Notify that the tasking run time has been elaborated so that -- the tasking version of the soft links can be used. - SSL.Lock_Task := Task_Lock'Access; - SSL.Unlock_Task := Task_Unlock'Access; - SSL.Adafinal := Finalize_Global_Tasks'Access; + SSL.Lock_Task := Task_Lock'Access; + SSL.Unlock_Task := Task_Unlock'Access; + SSL.Adafinal := Finalize_Global_Tasks'Access; + SSL.Get_Current_Excep := Get_Current_Excep'Access; -- Initialize the tasking soft links (if not done yet) that are common -- to the full and the restricted run times. diff --git a/gcc/ada/s-taskin.ads b/gcc/ada/s-taskin.ads index ae6908dac49..dad836c824c 100644 --- a/gcc/ada/s-taskin.ads +++ b/gcc/ada/s-taskin.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -55,7 +55,7 @@ with System.Task_Primitives; with System.Stack_Usage; -- used for Stack_Analyzer -with Unchecked_Conversion; +with Ada.Unchecked_Conversion; package System.Tasking is pragma Preelaborate; @@ -128,8 +128,10 @@ package System.Tasking is -- This is the compiler interface version of this function. Do not call -- from the run-time system. - function To_Task_Id is new Unchecked_Conversion (System.Address, Task_Id); - function To_Address is new Unchecked_Conversion (Task_Id, System.Address); + function To_Task_Id is + new Ada.Unchecked_Conversion (System.Address, Task_Id); + function To_Address is + new Ada.Unchecked_Conversion (Task_Id, System.Address); ----------------------- -- Enumeration types -- @@ -200,8 +202,8 @@ package System.Tasking is -- The task has been held by Asynchronous_Task_Control.Hold_Task Interrupt_Server_Blocked_On_Event_Flag - -- The task has been blocked on a system call waiting for the - -- completion event. + -- The task has been blocked on a system call waiting for a + -- completion event/signal to occur. ); type Call_Modes is @@ -473,7 +475,7 @@ package System.Tasking is -- are invoked from protected actions. pragma Atomic is used because it -- can be read/written from protected interrupt handlers. - Task_Image : String (1 .. 32); + Task_Image : String (1 .. System.Parameters.Max_Task_Image_Length); -- Hold a string that provides a readable id for task, -- built from the variable of which it is a value or component. @@ -991,8 +993,8 @@ package System.Tasking is -- this value. Deferral_Level : Natural := 1; - -- This is the number of times that Defer_Abortion has been called by - -- this task without a matching Undefer_Abortion call. Abortion is only + -- This is the number of times that Defer_Abort has been called by + -- this task without a matching Undefer_Abort call. Abortion is only -- allowed when this zero. It is initially 1, to protect the task at -- startup. @@ -1065,6 +1067,7 @@ package System.Tasking is -- documentation, mention T, and describe Success ??? private + Null_Task : constant Task_Id := null; type Activation_Chain is limited record diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index d6fe66c1f4e..28284322f8d 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -66,7 +66,6 @@ with System.Tasking.Initialization; -- Used for Remove_From_All_Tasks_List -- Defer_Abort -- Undefer_Abort --- Initialization.Poll_Base_Priority_Change -- Finalize_Attributes_Link -- Initialize_Attributes_Link @@ -102,7 +101,7 @@ with System.Standard_Library; with System.Traces.Tasking; -- Used for Send_Trace_Info -with Unchecked_Deallocation; +with Ada.Unchecked_Deallocation; -- To recover from failure of ATCB initialization with System.Stack_Usage; @@ -129,7 +128,7 @@ package body System.Tasking.Stages is ----------------------- procedure Free is new - Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id); -- This procedure outputs the task specific message for exception @@ -179,7 +178,7 @@ package body System.Tasking.Stages is -- For tasks created by an allocator that fails, due to an exception, -- it is called from Expunge_Unactivated_Tasks. -- - -- It is also called from Unchecked_Deallocation, for objects that + -- It is also called from Ada.Unchecked_Deallocation, for objects that -- are or contain tasks. -- -- Different code is used at master completion, in Terminate_Dependents, @@ -387,7 +386,7 @@ package body System.Tasking.Stages is Write_Lock (Self_ID); Self_ID.Common.State := Activator_Sleep; - C := Chain_Access.T_ID; + C := Chain_Access.T_ID; while C /= null loop Write_Lock (C); @@ -411,7 +410,6 @@ package body System.Tasking.Stages is -- unsafe to abort any of these tasks until the count goes to zero. loop - Initialization.Poll_Base_Priority_Change (Self_ID); exit when Self_ID.Common.Wait_Count = 0; Sleep (Self_ID, Activator_Sleep); end loop; @@ -472,7 +470,9 @@ package body System.Tasking.Stages is procedure Complete_Master is Self_ID : constant Task_Id := STPO.Self; begin - pragma Assert (Self_ID.Deferral_Level > 0); + pragma Assert + (Self_ID.Deferral_Level > 0 + or else not System.Restrictions.Abort_Allowed); Vulnerable_Complete_Master (Self_ID); end Complete_Master; @@ -486,7 +486,9 @@ package body System.Tasking.Stages is Self_ID : constant Task_Id := STPO.Self; begin - pragma Assert (Self_ID.Deferral_Level > 0); + pragma Assert + (Self_ID.Deferral_Level > 0 + or else not System.Restrictions.Abort_Allowed); Vulnerable_Complete_Task (Self_ID); @@ -953,9 +955,7 @@ package body System.Tasking.Stages is Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size * SSE.Storage_Offset (Parameters.Sec_Stack_Ratio) / 100; - Secondary_Stack : - aliased SSE.Storage_Array - (1 .. Secondary_Stack_Size); + Secondary_Stack : aliased SSE.Storage_Array (1 .. Secondary_Stack_Size); pragma Warnings (Off); Secondary_Stack_Address : System.Address := Secondary_Stack'Address; @@ -969,6 +969,9 @@ package body System.Tasking.Stages is Size : Natural := Natural (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size); + Overflow_Guard : Natural; + -- Size of the overflow guard, used by dynamic stack usage analysis + pragma Warnings (On); -- Address of secondary stack. In the fixed secondary stack case, this -- value is not modified, causing a warning, hence the bracketing with @@ -1004,6 +1007,10 @@ package body System.Tasking.Stages is -- master relationship. If the handler is found, its pointer is stored -- in TH. + ------------------------------ + -- Search_Fall_Back_Handler -- + ------------------------------ + procedure Search_Fall_Back_Handler (ID : Task_Id) is begin -- If there is a fall back handler, store its pointer for later @@ -1030,11 +1037,13 @@ package body System.Tasking.Stages is -- Assume a size of the stack taken at this stage if Size < Small_Stack_Limit then - Size := Size - Small_Overflow_Guard; + Overflow_Guard := Small_Overflow_Guard; else - Size := Size - Big_Overflow_Guard; + Overflow_Guard := Big_Overflow_Guard; end if; + Size := Size - Overflow_Guard; + if not Parameters.Sec_Stack_Dynamic then Self_ID.Common.Compiler_Data.Sec_Stack_Addr := Secondary_Stack'Address; @@ -1048,6 +1057,7 @@ package body System.Tasking.Stages is Self_ID.Common.Task_Image (1 .. Self_ID.Common.Task_Image_Len), Size, + Overflow_Guard, SSE.To_Integer (Bottom_Of_Stack'Address)); STPO.Unlock_RTS; Fill_Stack (Self_ID.Common.Analyzer); @@ -1225,7 +1235,7 @@ package body System.Tasking.Stages is -- since the operation Task_Unlock continued to access the ATCB after -- unlocking, after which the parent was observed to race ahead, deallocate -- the ATCB, and then reallocate it to another task. The call to - -- Undefer_Abortion in Task_Unlock by the "terminated" task was overwriting + -- Undefer_Abort in Task_Unlock by the "terminated" task was overwriting -- the data of the new task that reused the ATCB! To solve this problem, we -- introduced the new operation Final_Task_Unlock. @@ -1334,7 +1344,7 @@ package body System.Tasking.Stages is use System.Standard_Library; function To_Address is new - Unchecked_Conversion (Task_Id, System.Address); + Ada.Unchecked_Conversion (Task_Id, System.Address); function Tailored_Exception_Information (E : Exception_Occurrence) return String; @@ -1492,7 +1502,9 @@ package body System.Tasking.Stages is (Debug.Trace (Self_ID, "V_Complete_Master", 'C')); pragma Assert (Self_ID.Common.Wait_Count = 0); - pragma Assert (Self_ID.Deferral_Level > 0); + pragma Assert + (Self_ID.Deferral_Level > 0 + or else not System.Restrictions.Abort_Allowed); -- Count how many active dependent tasks this master currently -- has, and record this in Wait_Count. @@ -1559,7 +1571,6 @@ package body System.Tasking.Stages is Write_Lock (Self_ID); loop - Initialization.Poll_Base_Priority_Change (Self_ID); exit when Self_ID.Common.Wait_Count = 0; -- Here is a difference as compared to Complete_Master @@ -1659,7 +1670,6 @@ package body System.Tasking.Stages is Write_Lock (Self_ID); loop - Initialization.Poll_Base_Priority_Change (Self_ID); exit when Self_ID.Common.Wait_Count = 0; Sleep (Self_ID, Master_Phase_2_Sleep); end loop; @@ -1813,7 +1823,9 @@ package body System.Tasking.Stages is procedure Vulnerable_Complete_Task (Self_ID : Task_Id) is begin - pragma Assert (Self_ID.Deferral_Level > 0); + pragma Assert + (Self_ID.Deferral_Level > 0 + or else not System.Restrictions.Abort_Allowed); pragma Assert (Self_ID = Self); pragma Assert (Self_ID.Master_Within = Self_ID.Master_of_Task + 1 or else @@ -1869,7 +1881,7 @@ package body System.Tasking.Stages is -- For tasks created by elaboration of task object declarations it -- is called from the finalization code of the Task_Wrapper procedure. - -- It is also called from Unchecked_Deallocation, for objects that + -- It is also called from Ada.Unchecked_Deallocation, for objects that -- are or contain tasks. procedure Vulnerable_Free_Task (T : Task_Id) is diff --git a/gcc/ada/s-tataat.adb b/gcc/ada/s-tataat.adb index c0dede8cc44..1c672769e7f 100644 --- a/gcc/ada/s-tataat.adb +++ b/gcc/ada/s-tataat.adb @@ -7,7 +7,7 @@ -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2006, AdaCore -- +-- Copyright (C) 1995-2007, AdaCore -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -41,14 +41,14 @@ with System.Tasking.Initialization; -- used for Defer_Abort -- Undefer_Abort -with Unchecked_Conversion; +with Ada.Unchecked_Conversion; package body System.Tasking.Task_Attributes is use Task_Primitives.Operations; use Tasking.Initialization; - function To_Access_Address is new Unchecked_Conversion + function To_Access_Address is new Ada.Unchecked_Conversion (Access_Node, Access_Address); -- Store pointer to indirect attribute list @@ -61,10 +61,15 @@ package body System.Tasking.Task_Attributes is Self_Id : constant Task_Id := Self; begin - Defer_Abort (Self_Id); + -- Defer abort. Note that we use the nestable versions of Defer_Abort + -- and Undefer_Abort, because abort can already deferred when this is + -- called during finalization, which would cause an assert failure + -- in Defer_Abort. + + Defer_Abort_Nestable (Self_Id); Lock_RTS; - -- Remove this instantiation from the list of all instantiations. + -- Remove this instantiation from the list of all instantiations declare P : Access_Instance; @@ -85,7 +90,8 @@ package body System.Tasking.Task_Attributes is end; if X.Index /= 0 then - -- Free location of this attribute, for reuse. + + -- Free location of this attribute, for reuse In_Use := In_Use and not (2**Natural (X.Index)); @@ -140,7 +146,7 @@ package body System.Tasking.Task_Attributes is X.Deallocate.all (Q); end loop; - Undefer_Abort (Self_Id); + Undefer_Abort_Nestable (Self_Id); exception when others => diff --git a/gcc/ada/s-tpoben.adb b/gcc/ada/s-tpoben.adb index f15afc05092..b3efad52af1 100644 --- a/gcc/ada/s-tpoben.adb +++ b/gcc/ada/s-tpoben.adb @@ -7,7 +7,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2007, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -54,6 +54,7 @@ with System.Task_Primitives.Operations; -- Unlock -- Get_Priority -- Wakeup +-- Set_Ceiling with System.Tasking.Initialization; -- Used for Defer_Abort, @@ -64,6 +65,9 @@ pragma Elaborate_All (System.Tasking.Initialization); -- This insures that tasking is initialized if any protected objects are -- created. +with System.Restrictions; +-- Used for Abort_Allowed + with System.Parameters; -- Used for Single_Lock @@ -216,13 +220,15 @@ package body System.Tasking.Protected_Objects.Entries is Initialization.Defer_Abort (Self_ID); Initialize_Lock (Init_Priority, Object.L'Access); Initialization.Undefer_Abort (Self_ID); - Object.Ceiling := System.Any_Priority (Init_Priority); - Object.Owner := Null_Task; - Object.Compiler_Info := Compiler_Info; - Object.Pending_Action := False; + + Object.Ceiling := System.Any_Priority (Init_Priority); + Object.New_Ceiling := System.Any_Priority (Init_Priority); + Object.Owner := Null_Task; + Object.Compiler_Info := Compiler_Info; + Object.Pending_Action := False; Object.Call_In_Progress := null; - Object.Entry_Bodies := Entry_Bodies; - Object.Find_Body_Index := Find_Body_Index; + Object.Entry_Bodies := Entry_Bodies; + Object.Find_Body_Index := Find_Body_Index; for E in Object.Entry_Queues'Range loop Object.Entry_Queues (E).Head := null; @@ -235,7 +241,8 @@ package body System.Tasking.Protected_Objects.Entries is ------------------ procedure Lock_Entries - (Object : Protection_Entries_Access; Ceiling_Violation : out Boolean) + (Object : Protection_Entries_Access; + Ceiling_Violation : out Boolean) is begin if Object.Finalized then @@ -264,7 +271,10 @@ package body System.Tasking.Protected_Objects.Entries is -- generated calls must be protected with cleanup handlers to ensure -- that abort is undeferred in all cases. - pragma Assert (STPO.Self.Deferral_Level > 0); + pragma Assert + (STPO.Self.Deferral_Level > 0 + or else not Restrictions.Abort_Allowed); + Write_Lock (Object.L'Access, Ceiling_Violation); -- We are entering in a protected action, so that we increase the @@ -401,6 +411,18 @@ package body System.Tasking.Protected_Objects.Entries is end; end if; + -- Before releasing the mutex we must actually update its ceiling + -- priority if it has been changed. + + if Object.New_Ceiling /= Object.Ceiling then + if Locking_Policy = 'C' then + System.Task_Primitives.Operations.Set_Ceiling + (Object.L'Access, Object.New_Ceiling); + end if; + + Object.Ceiling := Object.New_Ceiling; + end if; + Unlock (Object.L'Access); end Unlock_Entries; diff --git a/gcc/ada/s-tpobop.adb b/gcc/ada/s-tpobop.adb index 95d54af7552..867e51c8f81 100644 --- a/gcc/ada/s-tpobop.adb +++ b/gcc/ada/s-tpobop.adb @@ -7,7 +7,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2007, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -562,7 +562,7 @@ package body System.Tasking.Protected_Objects.Operations is Mode : Call_Modes; Block : out Communication_Block) is - Self_ID : constant Task_Id := STPO.Self; + Self_ID : constant Task_Id := STPO.Self; Entry_Call : Entry_Call_Link; Initially_Abortable : Boolean; Ceiling_Violation : Boolean; @@ -591,14 +591,17 @@ package body System.Tasking.Protected_Objects.Operations is (Program_Error'Identity, "potentially blocking operation"); end if; - Initialization.Defer_Abort (Self_ID); + -- Self_ID.Deferral_Level should be 0, except when called from Finalize, + -- where abort is already deferred. + + Initialization.Defer_Abort_Nestable (Self_ID); Lock_Entries (Object, Ceiling_Violation); if Ceiling_Violation then -- Failed ceiling check - Initialization.Undefer_Abort (Self_ID); + Initialization.Undefer_Abort_Nestable (Self_ID); raise Program_Error; end if; @@ -651,7 +654,7 @@ package body System.Tasking.Protected_Objects.Operations is Block.Enqueued := False; Block.Cancelled := Entry_Call.State = Cancelled; - Initialization.Undefer_Abort (Self_ID); + Initialization.Undefer_Abort_Nestable (Self_ID); Entry_Calls.Check_Exception (Self_ID, Entry_Call); return; @@ -698,7 +701,7 @@ package body System.Tasking.Protected_Objects.Operations is null; end if; - Initialization.Undefer_Abort (Self_ID); + Initialization.Undefer_Abort_Nestable (Self_ID); Entry_Calls.Check_Exception (Self_ID, Entry_Call); end Protected_Entry_Call; diff --git a/gcc/ada/s-tpobop.ads b/gcc/ada/s-tpobop.ads index 25b641dbe29..7c0a5714c1a 100644 --- a/gcc/ada/s-tpobop.ads +++ b/gcc/ada/s-tpobop.ads @@ -7,7 +7,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -88,9 +88,9 @@ package System.Tasking.Protected_Objects.Operations is Timeout : Duration; Mode : Delay_Modes; Entry_Call_Successful : out Boolean); - -- Same as the Protected_Entry_Call but with time-out specified. - -- This routines is used when we do not use ATC mechanism to implement - -- timed entry calls. + -- Same as the Protected_Entry_Call but with time-out specified. + -- This routines is used when we do not use ATC mechanism to implement + -- timed entry calls. procedure Service_Entries (Object : Entries.Protection_Entries_Access); pragma Inline (Service_Entries); diff --git a/gcc/ada/s-tposen.adb b/gcc/ada/s-tposen.adb index e5bf8fb26c9..38554fa53e3 100644 --- a/gcc/ada/s-tposen.adb +++ b/gcc/ada/s-tposen.adb @@ -7,7 +7,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2007, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -548,10 +548,8 @@ package body System.Tasking.Protected_Objects.Single_Entry is Uninterpreted_Data : System.Address; Mode : Call_Modes) is - Self_Id : constant Task_Id := STPO.Self; - Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1); - Ceiling_Violation : Boolean; - + Self_Id : constant Task_Id := STPO.Self; + Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1); begin -- If pragma Detect_Blocking is active then Program_Error must be -- raised if this potentially blocking operation is called from a @@ -564,11 +562,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is (Program_Error'Identity, "potentially blocking operation"); end if; - STPO.Write_Lock (Object.L'Access, Ceiling_Violation); - - if Ceiling_Violation then - raise Program_Error; - end if; + Lock_Entry (Object); Entry_Call.Mode := Mode; Entry_Call.State := Now_Abortable; -- 2.30.2