-- --
-- 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- --
with System.Parameters;
-- used for Single_Lock
-with Unchecked_Conversion;
+with Ada.Unchecked_Conversion;
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);
-----------------
-- 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.
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;
--------------------
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));
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
-- 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
-- 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.
-- --
-- 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- --
(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).
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
-- 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;
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;
-- used for Write_Lock
-- Unlock
-- Self
+-- Set_Ceiling
with System.Parameters;
-- used for Runtime_Traces
use System.Task_Primitives.Operations;
use System.Traces;
+ ----------------
+ -- Local Data --
+ ----------------
+
+ Locking_Policy : Character;
+ pragma Import (C, Locking_Policy, "__gl_locking_policy");
+
-------------------------
-- Finalize_Protection --
-------------------------
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
-- --
-- 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- --
-- 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.
-- 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);
-- 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);
-- 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
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
-- 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
-- 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
-- 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
-- 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
-- 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
-- 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 --
---------------
-- 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.
-- --
-- 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- --
with System.Stack_Usage;
-- used for Stack_Analyzer
-with Unchecked_Conversion;
+with Ada.Unchecked_Conversion;
package System.Tasking is
pragma Preelaborate;
-- 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 --
-- 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
-- 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.
-- 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.
-- documentation, mention T, and describe Success ???
private
+
Null_Task : constant Task_Id := null;
type Activation_Chain is limited record
-- --
-- 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- --
-- Used for Remove_From_All_Tasks_List
-- Defer_Abort
-- Undefer_Abort
--- Initialization.Poll_Base_Priority_Change
-- Finalize_Attributes_Link
-- Initialize_Attributes_Link
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;
-----------------------
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
-- 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,
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);
-- 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;
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;
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);
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;
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
-- 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
-- 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;
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);
-- 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.
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;
(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.
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
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;
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
-- 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
-- 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- --
-- 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
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;
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));
X.Deallocate.all (Q);
end loop;
- Undefer_Abort (Self_Id);
+ Undefer_Abort_Nestable (Self_Id);
exception
when others =>
-- --
-- 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- --
-- Unlock
-- Get_Priority
-- Wakeup
+-- Set_Ceiling
with System.Tasking.Initialization;
-- Used for Defer_Abort,
-- 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
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;
------------------
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
-- 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
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;
-- --
-- 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- --
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;
(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;
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;
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;
-- --
-- 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- --
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);
-- --
-- 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- --
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
(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;
projects / gcc.git / commitdiff