1 ------------------------------------------------------------------------------
3 -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- S Y S T E M . T A S K I N G . I N I T I A L I Z A T I O N --
10 -- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
12 -- GNARL is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNARL; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- GNARL was developed by the GNARL team at Florida State University. It is --
31 -- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
33 ------------------------------------------------------------------------------
35 pragma Style_Checks
(All_Checks
);
36 -- Turn off subprogram alpha ordering check, since we group soft link
37 -- bodies and dummy soft link bodies together separately in this unit.
40 -- Turn polling off for this package. We don't need polling during any
41 -- of the routines in this package, and more to the point, if we try
42 -- to poll it can cause infinite loops.
45 -- used for Exception_Occurrence_Access.
48 pragma Elaborate_All
(System
.Tasking
);
49 -- ensure that the first step initializations have been performed
51 with System
.Task_Primitives
;
54 with System
.Task_Primitives
.Operations
;
55 -- used for Set_Priority
60 with System
.Soft_Links
;
61 -- used for the non-tasking routines (*_NT) that refer to global data.
62 -- They are needed here before the tasking run time has been elaborated.
64 with System
.Tasking
.Debug
;
67 with System
.Stack_Checking
;
69 with System
.Parameters
;
70 -- used for Single_Lock
72 package body System
.Tasking
.Initialization
is
74 package STPO
renames System
.Task_Primitives
.Operations
;
75 package SSL
renames System
.Soft_Links
;
76 package AE
renames Ada
.Exceptions
;
79 use Task_Primitives
.Operations
;
81 Global_Task_Lock
: aliased System
.Task_Primitives
.RTS_Lock
;
82 -- This is a global lock; it is used to execute in mutual exclusion
83 -- from all other tasks. It is only used by Task_Lock,
84 -- Task_Unlock, and Final_Task_Unlock.
86 function Current_Target_Exception
return AE
.Exception_Occurrence
;
88 (Ada
, Current_Target_Exception
, "__gnat_current_target_exception");
89 -- Import this subprogram from the private part of Ada.Exceptions.
91 -----------------------------------------------------------------
92 -- Tasking versions of services needed by non-tasking programs --
93 -----------------------------------------------------------------
96 -- Locks out other tasks. Preceding a section of code by Task_Lock and
97 -- following it by Task_Unlock creates a critical region. This is used
98 -- for ensuring that a region of non-tasking code (such as code used to
99 -- allocate memory) is tasking safe. Note that it is valid for calls to
100 -- Task_Lock/Task_Unlock to be nested, and this must work properly, i.e.
101 -- only the corresponding outer level Task_Unlock will actually unlock.
103 procedure Task_Unlock
;
104 -- Releases lock previously set by call to Task_Lock. In the nested case,
105 -- all nested locks must be released before other tasks competing for the
106 -- tasking lock are released.
108 function Get_Jmpbuf_Address
return Address
;
109 procedure Set_Jmpbuf_Address
(Addr
: Address
);
110 -- Get/Set Jmpbuf_Address for current task
112 function Get_Sec_Stack_Addr
return Address
;
113 procedure Set_Sec_Stack_Addr
(Addr
: Address
);
114 -- Get/Set location of current task's secondary stack
116 function Get_Exc_Stack_Addr
return Address
;
117 -- Get the exception stack for the current task
119 procedure Set_Exc_Stack_Addr
(Self_ID
: Address
; Addr
: Address
);
120 -- Self_ID is the Task_ID of the task that gets the exception stack.
121 -- For Self_ID = Null_Address, the current task gets the exception stack.
123 function Get_Machine_State_Addr
return Address
;
124 procedure Set_Machine_State_Addr
(Addr
: Address
);
125 -- Get/Set the address for storing the current task's machine state
127 function Get_Current_Excep
return SSL
.EOA
;
128 -- Comments needed???
130 procedure Timed_Delay_T
(Time
: Duration; Mode
: Integer);
131 -- Comments needed???
133 function Get_Stack_Info
return Stack_Checking
.Stack_Access
;
134 -- Get access to the current task's Stack_Info
136 procedure Update_Exception
137 (X
: AE
.Exception_Occurrence
:= Current_Target_Exception
);
138 -- Handle exception setting and check for pending actions
140 function Task_Name
return String;
141 -- Returns current task's name
143 ------------------------
144 -- Local Subprograms --
145 ------------------------
147 procedure Do_Pending_Action
(Self_ID
: Task_ID
);
148 -- This is introduced to allow more efficient
149 -- in-line expansion of Undefer_Abort.
151 ----------------------------
152 -- Tasking Initialization --
153 ----------------------------
156 -- This procedure completes the initialization of the GNARL. The first
157 -- part of the initialization is done in the body of System.Tasking.
158 -- It consists of initializing global locks, and installing tasking
159 -- versions of certain operations used by the compiler. Init_RTS is called
160 -- during elaboration.
162 --------------------------
163 -- Change_Base_Priority --
164 --------------------------
166 -- Call only with abort deferred and holding Self_ID locked.
168 procedure Change_Base_Priority
(T
: Task_ID
) is
170 if T
.Common
.Base_Priority
/= T
.New_Base_Priority
then
171 T
.Common
.Base_Priority
:= T
.New_Base_Priority
;
172 Set_Priority
(T
, T
.Common
.Base_Priority
);
174 end Change_Base_Priority
;
176 ------------------------
177 -- Check_Abort_Status --
178 ------------------------
180 function Check_Abort_Status
return Integer is
181 Self_ID
: constant Task_ID
:= Self
;
183 if Self_ID
/= null and then Self_ID
.Deferral_Level
= 0
184 and then Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
190 end Check_Abort_Status
;
196 procedure Defer_Abort
(Self_ID
: Task_ID
) is
198 if No_Abort
and then not Dynamic_Priority_Support
then
202 pragma Assert
(Self_ID
.Deferral_Level
= 0);
205 -- (Self_ID.Pending_ATC_Level >= Self_ID.ATC_Nesting_Level);
207 -- The above check has been useful in detecting mismatched defer/undefer
208 -- pairs. You may uncomment it when testing on systems that support
211 -- If the OS supports preemptive abort (e.g. pthread_kill), it should
212 -- have happened already. A problem is with systems that do not support
213 -- preemptive abort, and so rely on polling. On such systems we may get
214 -- false failures of the assertion, since polling for pending abort does
215 -- no occur until the abort undefer operation.
217 -- Even on systems that only poll for abort, the assertion may be useful
218 -- for catching missed abort completion polling points. The operations
219 -- that undefer abort poll for pending aborts. This covers most of the
220 -- places where the core Ada semantics require abort to be caught,
221 -- without any special attention. However, this generally happens on
222 -- exit from runtime system call, which means a pending abort will not
223 -- be noticed on the way into the runtime system. We considered adding a
224 -- check for pending aborts at this point, but chose not to, because of
225 -- the overhead. Instead, we searched for RTS calls where abort
226 -- completion is required and a task could go farther than Ada allows
227 -- before undeferring abort; we then modified the code to ensure the
228 -- abort would be detected.
230 Self_ID
.Deferral_Level
:= Self_ID
.Deferral_Level
+ 1;
233 --------------------------
234 -- Defer_Abort_Nestable --
235 --------------------------
237 procedure Defer_Abort_Nestable
(Self_ID
: Task_ID
) is
239 if No_Abort
and then not Dynamic_Priority_Support
then
244 -- ((Self_ID.Pending_ATC_Level >= Self_ID.ATC_Nesting_Level or else
245 -- Self_ID.Deferral_Level > 0));
247 -- See comment in Defer_Abort on the situations in which it may be
248 -- useful to uncomment the above assertion.
250 Self_ID
.Deferral_Level
:= Self_ID
.Deferral_Level
+ 1;
251 end Defer_Abort_Nestable
;
257 procedure Defer_Abortion
is
261 if No_Abort
and then not Dynamic_Priority_Support
then
265 Self_ID
:= STPO
.Self
;
266 Self_ID
.Deferral_Level
:= Self_ID
.Deferral_Level
+ 1;
269 -----------------------
270 -- Do_Pending_Action --
271 -----------------------
273 -- Call only when holding no locks
275 procedure Do_Pending_Action
(Self_ID
: Task_ID
) is
276 use type Ada
.Exceptions
.Exception_Id
;
279 pragma Assert
(Self_ID
= Self
and then Self_ID
.Deferral_Level
= 0);
281 -- Needs loop to recheck for pending action in case a new one occurred
282 -- while we had abort deferred below.
285 -- Temporarily defer abortion so that we can lock Self_ID.
287 Self_ID
.Deferral_Level
:= Self_ID
.Deferral_Level
+ 1;
293 Write_Lock
(Self_ID
);
294 Self_ID
.Pending_Action
:= False;
295 Poll_Base_Priority_Change
(Self_ID
);
302 -- Restore the original Deferral value.
304 Self_ID
.Deferral_Level
:= Self_ID
.Deferral_Level
- 1;
306 if not Self_ID
.Pending_Action
then
307 if Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
then
308 if not Self_ID
.Aborting
then
309 Self_ID
.Aborting
:= True;
311 (Debug
.Trace
(Self_ID
, "raise Abort_Signal", 'B'));
312 raise Standard
'Abort_Signal;
314 pragma Assert
(not Self_ID
.ATC_Hack
);
316 elsif Self_ID
.ATC_Hack
then
317 -- The solution really belongs in the Abort_Signal handler
318 -- for async. entry calls. The present hack is very
319 -- fragile. It relies that the very next point after
320 -- Exit_One_ATC_Level at which the task becomes abortable
321 -- will be the call to Undefer_Abort in the
322 -- Abort_Signal handler.
324 Self_ID
.ATC_Hack
:= False;
328 (Self_ID
, "raise Abort_Signal (ATC hack)", 'B'));
329 raise Standard
'Abort_Signal;
336 end Do_Pending_Action
;
338 -----------------------
339 -- Final_Task_Unlock --
340 -----------------------
342 -- This version is only for use in Terminate_Task, when the task
343 -- is relinquishing further rights to its own ATCB.
344 -- There is a very interesting potential race condition there, where
345 -- the old task may run concurrently with a new task that is allocated
346 -- the old tasks (now reused) ATCB. The critical thing here is to
347 -- not make any reference to the ATCB after the lock is released.
348 -- See also comments on Terminate_Task and Unlock.
350 procedure Final_Task_Unlock
(Self_ID
: Task_ID
) is
352 pragma Assert
(Self_ID
.Global_Task_Lock_Nesting
= 1);
353 Unlock
(Global_Task_Lock
'Access, Global_Lock
=> True);
354 end Final_Task_Unlock
;
360 procedure Init_RTS
is
364 -- Terminate run time (regular vs restricted) specific initialization
365 -- of the environment task.
367 Self_Id
:= Environment_Task
;
368 Self_Id
.Master_of_Task
:= Environment_Task_Level
;
369 Self_Id
.Master_Within
:= Self_Id
.Master_of_Task
+ 1;
371 for L
in Self_Id
.Entry_Calls
'Range loop
372 Self_Id
.Entry_Calls
(L
).Self
:= Self_Id
;
373 Self_Id
.Entry_Calls
(L
).Level
:= L
;
376 Self_Id
.Awake_Count
:= 1;
377 Self_Id
.Alive_Count
:= 1;
379 Self_Id
.Master_Within
:= Library_Task_Level
;
380 -- Normally, a task starts out with internal master nesting level
381 -- one larger than external master nesting level. It is incremented
382 -- to one by Enter_Master, which is called in the task body only if
383 -- the compiler thinks the task may have dependent tasks. There is no
384 -- corresponding call to Enter_Master for the environment task, so we
385 -- would need to increment it to 2 here. Instead, we set it to 3.
386 -- By doing this we reserve the level 2 for server tasks of the runtime
387 -- system. The environment task does not need to wait for these server
389 -- Initialize lock used to implement mutual exclusion between all tasks
391 Initialize_Lock
(Global_Task_Lock
'Access, STPO
.Global_Task_Level
);
393 -- Notify that the tasking run time has been elaborated so that
394 -- the tasking version of the soft links can be used.
396 if not No_Abort
or else Dynamic_Priority_Support
then
397 SSL
.Abort_Defer
:= Defer_Abortion
'Access;
398 SSL
.Abort_Undefer
:= Undefer_Abortion
'Access;
401 SSL
.Update_Exception
:= Update_Exception
'Access;
402 SSL
.Lock_Task
:= Task_Lock
'Access;
403 SSL
.Unlock_Task
:= Task_Unlock
'Access;
404 SSL
.Get_Jmpbuf_Address
:= Get_Jmpbuf_Address
'Access;
405 SSL
.Set_Jmpbuf_Address
:= Set_Jmpbuf_Address
'Access;
406 SSL
.Get_Sec_Stack_Addr
:= Get_Sec_Stack_Addr
'Access;
407 SSL
.Set_Sec_Stack_Addr
:= Set_Sec_Stack_Addr
'Access;
408 SSL
.Get_Exc_Stack_Addr
:= Get_Exc_Stack_Addr
'Access;
409 SSL
.Set_Exc_Stack_Addr
:= Set_Exc_Stack_Addr
'Access;
410 SSL
.Get_Machine_State_Addr
:= Get_Machine_State_Addr
'Access;
411 SSL
.Set_Machine_State_Addr
:= Set_Machine_State_Addr
'Access;
412 SSL
.Get_Current_Excep
:= Get_Current_Excep
'Access;
413 SSL
.Timed_Delay
:= Timed_Delay_T
'Access;
414 SSL
.Check_Abort_Status
:= Check_Abort_Status
'Access;
415 SSL
.Get_Stack_Info
:= Get_Stack_Info
'Access;
416 SSL
.Task_Name
:= Task_Name
'Access;
418 -- No need to create a new Secondary Stack, since we will use the
419 -- default one created in s-secsta.adb
421 SSL
.Set_Sec_Stack_Addr
(SSL
.Get_Sec_Stack_Addr_NT
);
422 SSL
.Set_Exc_Stack_Addr
(Null_Address
, SSL
.Get_Exc_Stack_Addr_NT
);
423 SSL
.Set_Jmpbuf_Address
(SSL
.Get_Jmpbuf_Address_NT
);
424 SSL
.Set_Machine_State_Addr
(SSL
.Get_Machine_State_Addr_NT
);
426 -- Abortion is deferred in a new ATCB, so we need to undefer abortion
427 -- at this stage to make the environment task abortable.
429 Undefer_Abort
(Environment_Task
);
432 ---------------------------
433 -- Locked_Abort_To_Level--
434 ---------------------------
436 -- Abort a task to the specified ATC nesting level.
437 -- Call this only with T locked.
439 -- An earlier version of this code contained a call to Wakeup. That
440 -- should not be necessary here, if Abort_Task is implemented correctly,
441 -- since Abort_Task should include the effect of Wakeup. However, the
442 -- above call was in earlier versions of this file, and at least for
443 -- some targets Abort_Task has not beek doing Wakeup. It should not
444 -- hurt to uncomment the above call, until the error is corrected for
447 -- See extended comments in package body System.Tasking.Abortion
448 -- for the overall design of the implementation of task abort.
450 -- If the task is sleeping it will be in an abort-deferred region,
451 -- and will not have Abort_Signal raised by Abort_Task.
452 -- Such an "abort deferral" is just to protect the RTS internals,
453 -- and not necessarily required to enforce Ada semantics.
454 -- Abort_Task should wake the task up and let it decide if it wants
455 -- to complete the aborted construct immediately.
457 -- Note that the effect of the lowl-level Abort_Task is not persistent.
458 -- If the target task is not blocked, this wakeup will be missed.
460 -- We don't bother calling Abort_Task if this task is aborting itself,
461 -- since we are inside the RTS and have abort deferred. Similarly, We
462 -- don't bother to call Abort_Task if T is terminated, since there is
463 -- no need to abort a terminated task, and it could be dangerous to try
464 -- if the task has stopped executing.
466 -- Note that an earlier version of this code had some false reasoning
467 -- about being able to reliably wake up a task that had suspended on
468 -- a blocking system call that does not atomically relase the task's
469 -- lock (e.g., UNIX nanosleep, which we once thought could be used to
470 -- implement delays). That still left the possibility of missed
473 -- We cannot safely call Vulnerable_Complete_Activation here,
474 -- since that requires locking Self_ID.Parent. The anti-deadlock
475 -- lock ordering rules would then require us to release the lock
476 -- on Self_ID first, which would create a timing window for other
477 -- tasks to lock Self_ID. This is significant for tasks that may be
478 -- aborted before their execution can enter the task body, and so
479 -- they do not get a chance to call Complete_Task. The actual work
480 -- for this case is done in Terminate_Task.
482 procedure Locked_Abort_To_Level
488 if not T
.Aborting
and then T
/= Self_ID
then
489 case T
.Common
.State
is
490 when Unactivated | Terminated
=>
491 pragma Assert
(False);
495 -- This is needed to cancel an asynchronous protected entry
496 -- call during a requeue with abort.
499 (T
.ATC_Nesting_Level
).Cancellation_Attempted
:= True;
501 when Interrupt_Server_Blocked_On_Event_Flag
=>
506 Interrupt_Server_Idle_Sleep |
507 Interrupt_Server_Blocked_Interrupt_Sleep |
510 Wakeup
(T
, T
.Common
.State
);
512 when Acceptor_Sleep
=>
513 T
.Open_Accepts
:= null;
514 Wakeup
(T
, T
.Common
.State
);
516 when Entry_Caller_Sleep
=>
518 (T
.ATC_Nesting_Level
).Cancellation_Attempted
:= True;
519 Wakeup
(T
, T
.Common
.State
);
521 when Activator_Sleep |
522 Master_Completion_Sleep |
523 Master_Phase_2_Sleep |
529 if T
.Pending_ATC_Level
> L
then
530 T
.Pending_ATC_Level
:= L
;
531 T
.Pending_Action
:= True;
537 -- This prevents aborted task from accepting calls
541 -- The test above is just a heuristic, to reduce wasteful
542 -- calls to Abort_Task. We are holding T locked, and this
543 -- value will not be set to False except with T also locked,
544 -- inside Exit_One_ATC_Level, so we should not miss wakeups.
546 if T
.Common
.State
= Acceptor_Sleep
then
547 T
.Open_Accepts
:= null;
550 elsif T
/= Self_ID
and then
551 (T
.Common
.State
= Runnable
552 or else T
.Common
.State
= Interrupt_Server_Blocked_On_Event_Flag
)
553 -- The task is blocked on a system call waiting for the
554 -- completion event. In this case Abort_Task may need to take
555 -- special action in order to succeed. Example system: VMS.
561 end Locked_Abort_To_Level
;
563 -------------------------------
564 -- Poll_Base_Priority_Change --
565 -------------------------------
567 -- Poll for pending base priority change and for held tasks.
568 -- This should always be called with (only) Self_ID locked.
569 -- It may temporarily release Self_ID's lock.
571 -- The call to Yield is to force enqueuing at the
572 -- tail of the dispatching queue.
574 -- We must unlock Self_ID for this to take effect,
575 -- since we are inheriting high active priority from the lock.
577 -- See also Poll_Base_Priority_Change_At_Entry_Call,
578 -- in package System.Tasking.Entry_Calls.
580 -- In this version, we check if the task is held too because
581 -- doing this only in Do_Pending_Action is not enough.
583 procedure Poll_Base_Priority_Change
(Self_ID
: Task_ID
) is
585 if Dynamic_Priority_Support
and then Self_ID
.Pending_Priority_Change
then
586 -- Check for ceiling violations ???
588 Self_ID
.Pending_Priority_Change
:= False;
590 if Self_ID
.Common
.Base_Priority
= Self_ID
.New_Base_Priority
then
598 Write_Lock
(Self_ID
);
601 elsif Self_ID
.Common
.Base_Priority
< Self_ID
.New_Base_Priority
then
602 Self_ID
.Common
.Base_Priority
:= Self_ID
.New_Base_Priority
;
603 Set_Priority
(Self_ID
, Self_ID
.Common
.Base_Priority
);
608 Self_ID
.Common
.Base_Priority
:= Self_ID
.New_Base_Priority
;
609 Set_Priority
(Self_ID
, Self_ID
.Common
.Base_Priority
);
618 Write_Lock
(Self_ID
);
622 end Poll_Base_Priority_Change
;
624 --------------------------------
625 -- Remove_From_All_Tasks_List --
626 --------------------------------
628 procedure Remove_From_All_Tasks_List
(T
: Task_ID
) is
634 (Debug
.Trace
("Remove_From_All_Tasks_List", 'C'));
636 Previous
:= Null_Task
;
639 while C
/= Null_Task
loop
641 if Previous
= Null_Task
then
643 All_Tasks_List
.Common
.All_Tasks_Link
;
645 Previous
.Common
.All_Tasks_Link
:= C
.Common
.All_Tasks_Link
;
652 C
:= C
.Common
.All_Tasks_Link
;
655 pragma Assert
(False);
656 end Remove_From_All_Tasks_List
;
662 procedure Task_Lock
(Self_ID
: Task_ID
) is
664 Self_ID
.Global_Task_Lock_Nesting
:= Self_ID
.Global_Task_Lock_Nesting
+ 1;
666 if Self_ID
.Global_Task_Lock_Nesting
= 1 then
667 Defer_Abort_Nestable
(Self_ID
);
668 Write_Lock
(Global_Task_Lock
'Access, Global_Lock
=> True);
672 procedure Task_Lock
is
674 Task_Lock
(STPO
.Self
);
681 function Task_Name
return String is
682 use System
.Task_Info
;
685 if STPO
.Self
.Common
.Task_Image
/= null then
686 return STPO
.Self
.Common
.Task_Image
.all;
696 procedure Task_Unlock
(Self_ID
: Task_ID
) is
698 pragma Assert
(Self_ID
.Global_Task_Lock_Nesting
> 0);
699 Self_ID
.Global_Task_Lock_Nesting
:= Self_ID
.Global_Task_Lock_Nesting
- 1;
701 if Self_ID
.Global_Task_Lock_Nesting
= 0 then
702 Unlock
(Global_Task_Lock
'Access, Global_Lock
=> True);
703 Undefer_Abort_Nestable
(Self_ID
);
707 procedure Task_Unlock
is
709 Task_Unlock
(STPO
.Self
);
716 -- Precondition : Self does not hold any locks!
718 -- Undefer_Abort is called on any abortion completion point (aka.
719 -- synchronization point). It performs the following actions if they
720 -- are pending: (1) change the base priority, (2) abort the task.
722 -- The priority change has to occur before abortion. Otherwise, it would
723 -- take effect no earlier than the next abortion completion point.
725 procedure Undefer_Abort
(Self_ID
: Task_ID
) is
727 if No_Abort
and then not Dynamic_Priority_Support
then
731 pragma Assert
(Self_ID
.Deferral_Level
= 1);
733 Self_ID
.Deferral_Level
:= Self_ID
.Deferral_Level
- 1;
735 if Self_ID
.Deferral_Level
= 0 then
736 pragma Assert
(Check_No_Locks
(Self_ID
));
738 if Self_ID
.Pending_Action
then
739 Do_Pending_Action
(Self_ID
);
744 ----------------------------
745 -- Undefer_Abort_Nestable --
746 ----------------------------
748 -- An earlier version would re-defer abort if an abort is in progress.
749 -- Then, we modified the effect of the raise statement so that it defers
750 -- abort until control reaches a handler. That was done to prevent
751 -- "skipping over" a handler if another asynchronous abort occurs during
752 -- the propagation of the abort to the handler.
754 -- There has been talk of reversing that decision, based on a newer
755 -- implementation of exception propagation. Care must be taken to evaluate
756 -- how such a change would interact with the above code and all the places
757 -- where abort-deferral is used to bridge over critical transitions, such
758 -- as entry to the scope of a region with a finalizer and entry into the
759 -- body of an accept-procedure.
761 procedure Undefer_Abort_Nestable
(Self_ID
: Task_ID
) is
763 if No_Abort
and then not Dynamic_Priority_Support
then
767 pragma Assert
(Self_ID
.Deferral_Level
> 0);
769 Self_ID
.Deferral_Level
:= Self_ID
.Deferral_Level
- 1;
771 if Self_ID
.Deferral_Level
= 0 then
773 pragma Assert
(Check_No_Locks
(Self_ID
));
775 if Self_ID
.Pending_Action
then
776 Do_Pending_Action
(Self_ID
);
779 end Undefer_Abort_Nestable
;
781 ----------------------
782 -- Undefer_Abortion --
783 ----------------------
785 -- Phase out RTS-internal use of Undefer_Abortion
786 -- to reduce overhead due to multiple calls to Self.
788 procedure Undefer_Abortion
is
791 if No_Abort
and then not Dynamic_Priority_Support
then
795 Self_ID
:= STPO
.Self
;
796 pragma Assert
(Self_ID
.Deferral_Level
> 0);
798 Self_ID
.Deferral_Level
:= Self_ID
.Deferral_Level
- 1;
800 if Self_ID
.Deferral_Level
= 0 then
801 pragma Assert
(Check_No_Locks
(Self_ID
));
803 if Self_ID
.Pending_Action
then
804 Do_Pending_Action
(Self_ID
);
807 end Undefer_Abortion
;
809 ----------------------
810 -- Update_Exception --
811 ----------------------
813 -- Call only when holding no locks.
815 procedure Update_Exception
816 (X
: AE
.Exception_Occurrence
:= Current_Target_Exception
)
818 Self_Id
: constant Task_ID
:= Self
;
822 Save_Occurrence
(Self_Id
.Common
.Compiler_Data
.Current_Excep
, X
);
824 if Self_Id
.Deferral_Level
= 0 then
825 if Self_Id
.Pending_Action
then
826 Self_Id
.Pending_Action
:= False;
827 Self_Id
.Deferral_Level
:= Self_Id
.Deferral_Level
+ 1;
833 Write_Lock
(Self_Id
);
834 Self_Id
.Pending_Action
:= False;
835 Poll_Base_Priority_Change
(Self_Id
);
842 Self_Id
.Deferral_Level
:= Self_Id
.Deferral_Level
- 1;
844 if Self_Id
.Pending_ATC_Level
< Self_Id
.ATC_Nesting_Level
then
845 if not Self_Id
.Aborting
then
846 Self_Id
.Aborting
:= True;
847 raise Standard
'Abort_Signal;
852 end Update_Exception
;
854 --------------------------
855 -- Wakeup_Entry_Caller --
856 --------------------------
858 -- This is called at the end of service of an entry call, to abort the
859 -- caller if he is in an abortable part, and to wake up the caller if it
860 -- is on Entry_Caller_Sleep. It assumes that the call is already off-queue.
862 -- (This enforces the rule that a task must be off-queue if its state is
863 -- Done or Cancelled.) Call it holding the lock of Entry_Call.Self.
865 -- Timed_Call or Simple_Call:
866 -- The caller is waiting on Entry_Caller_Sleep, in
867 -- Wait_For_Completion, or Wait_For_Completion_With_Timeout.
870 -- The caller might be in Wait_For_Completion,
871 -- waiting for a rendezvous (possibly requeued without abort)
874 -- Asynchronous_Call:
875 -- The caller may be executing in the abortable part o
876 -- an async. select, or on a time delay,
877 -- if Entry_Call.State >= Was_Abortable.
879 procedure Wakeup_Entry_Caller
881 Entry_Call
: Entry_Call_Link
;
882 New_State
: Entry_Call_State
)
884 Caller
: constant Task_ID
:= Entry_Call
.Self
;
886 pragma Debug
(Debug
.Trace
887 (Self_ID
, "Wakeup_Entry_Caller", Caller
, 'E'));
888 pragma Assert
(New_State
= Done
or else New_State
= Cancelled
);
891 (Caller
.Common
.State
/= Terminated
892 and then Caller
.Common
.State
/= Unactivated
);
894 Entry_Call
.State
:= New_State
;
896 if Entry_Call
.Mode
= Asynchronous_Call
then
898 -- Abort the caller in his abortable part,
899 -- but do so only if call has been queued abortably
901 if Entry_Call
.State
>= Was_Abortable
or else New_State
= Done
then
902 Locked_Abort_To_Level
(Self_ID
, Caller
, Entry_Call
.Level
- 1);
905 elsif Caller
.Common
.State
= Entry_Caller_Sleep
then
906 Wakeup
(Caller
, Entry_Caller_Sleep
);
908 end Wakeup_Entry_Caller
;
910 ----------------------
911 -- Soft-Link Bodies --
912 ----------------------
914 function Get_Current_Excep
return SSL
.EOA
is
915 Me
: constant Task_ID
:= STPO
.Self
;
917 return Me
.Common
.Compiler_Data
.Current_Excep
'Access;
918 end Get_Current_Excep
;
920 function Get_Exc_Stack_Addr
return Address
is
921 Me
: constant Task_ID
:= STPO
.Self
;
923 return Me
.Common
.Compiler_Data
.Exc_Stack_Addr
;
924 end Get_Exc_Stack_Addr
;
926 function Get_Jmpbuf_Address
return Address
is
927 Me
: constant Task_ID
:= STPO
.Self
;
929 return Me
.Common
.Compiler_Data
.Jmpbuf_Address
;
930 end Get_Jmpbuf_Address
;
932 function Get_Machine_State_Addr
return Address
is
933 Me
: constant Task_ID
:= STPO
.Self
;
935 return Me
.Common
.Compiler_Data
.Machine_State_Addr
;
936 end Get_Machine_State_Addr
;
938 function Get_Sec_Stack_Addr
return Address
is
939 Me
: constant Task_ID
:= STPO
.Self
;
941 return Me
.Common
.Compiler_Data
.Sec_Stack_Addr
;
942 end Get_Sec_Stack_Addr
;
944 function Get_Stack_Info
return Stack_Checking
.Stack_Access
is
945 Me
: constant Task_ID
:= STPO
.Self
;
947 return Me
.Common
.Compiler_Data
.Pri_Stack_Info
'Access;
950 procedure Set_Exc_Stack_Addr
(Self_ID
: Address
; Addr
: Address
) is
951 Me
: Task_ID
:= To_Task_Id
(Self_ID
);
953 if Me
= Null_Task
then
957 Me
.Common
.Compiler_Data
.Exc_Stack_Addr
:= Addr
;
958 end Set_Exc_Stack_Addr
;
960 procedure Set_Jmpbuf_Address
(Addr
: Address
) is
961 Me
: Task_ID
:= STPO
.Self
;
963 Me
.Common
.Compiler_Data
.Jmpbuf_Address
:= Addr
;
964 end Set_Jmpbuf_Address
;
966 procedure Set_Machine_State_Addr
(Addr
: Address
) is
967 Me
: Task_ID
:= STPO
.Self
;
969 Me
.Common
.Compiler_Data
.Machine_State_Addr
:= Addr
;
970 end Set_Machine_State_Addr
;
972 procedure Set_Sec_Stack_Addr
(Addr
: Address
) is
973 Me
: Task_ID
:= STPO
.Self
;
975 Me
.Common
.Compiler_Data
.Sec_Stack_Addr
:= Addr
;
976 end Set_Sec_Stack_Addr
;
978 procedure Timed_Delay_T
(Time
: Duration; Mode
: Integer) is
980 STPO
.Timed_Delay
(STPO
.Self
, Time
, Mode
);
983 -----------------------
984 -- Soft-Link Dummies --
985 -----------------------
987 -- These are dummies for subprograms that are only needed by certain
988 -- optional run-time system packages. If they are needed, the soft
989 -- links will be redirected to the real subprogram by elaboration of
990 -- the subprogram body where the real subprogram is declared.
992 procedure Finalize_Attributes
(T
: Task_ID
) is
993 pragma Warnings
(Off
, T
);
996 end Finalize_Attributes
;
998 procedure Initialize_Attributes
(T
: Task_ID
) is
999 pragma Warnings
(Off
, T
);
1002 end Initialize_Attributes
;
1006 end System
.Tasking
.Initialization
;