s-taprob.adb (Unlock): Change the ceiling priority of the underlying lock, if needed.

2007-04-20  Jose Ruiz  <ruiz@adacore.com>
	    Arnaud Charlet  <charlet@adacore.com>

	* 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

@@ -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.
 

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).
 

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;
 

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

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
 

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.

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

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

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 =>

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;
 

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;
 

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);

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;