1 ------------------------------------------------------------------------------
3 -- GNAT 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 --
9 -- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
11 -- GNARL is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNARL; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNARL was developed by the GNARL team at Florida State University. --
30 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
32 ------------------------------------------------------------------------------
34 pragma Style_Checks
(All_Checks
);
35 -- Turn off subprogram alpha ordering check, since we group soft link
36 -- bodies and dummy soft link bodies together separately in this unit.
39 -- Turn polling off for this package. We don't need polling during any
40 -- of the routines in this package, and more to the point, if we try
41 -- to poll it can cause infinite loops.
44 -- Used for Exception_Occurrence_Access
46 with System
.Task_Primitives
;
49 with System
.Task_Primitives
.Operations
;
50 -- Used for Set_Priority
55 with System
.Soft_Links
;
56 -- Used for the non-tasking routines (*_NT) that refer to global data.
57 -- They are needed here before the tasking run time has been elaborated.
59 with System
.Soft_Links
.Tasking
;
60 -- Used for Init_Tasking_Soft_Links
62 with System
.Tasking
.Debug
;
65 with System
.Stack_Checking
;
67 with System
.Parameters
;
68 -- used for Single_Lock
70 package body System
.Tasking
.Initialization
is
72 package STPO
renames System
.Task_Primitives
.Operations
;
73 package SSL
renames System
.Soft_Links
;
74 package AE
renames Ada
.Exceptions
;
77 use Task_Primitives
.Operations
;
79 Global_Task_Lock
: aliased System
.Task_Primitives
.RTS_Lock
;
80 -- This is a global lock; it is used to execute in mutual exclusion
81 -- from all other tasks. It is only used by Task_Lock,
82 -- Task_Unlock, and Final_Task_Unlock.
84 function Current_Target_Exception
return AE
.Exception_Occurrence
;
86 (Ada
, Current_Target_Exception
, "__gnat_current_target_exception");
87 -- Import this subprogram from the private part of Ada.Exceptions
89 ----------------------------------------------------------------------
90 -- Tasking versions of some services needed by non-tasking programs --
91 ----------------------------------------------------------------------
93 procedure Abort_Defer
;
94 -- NON-INLINE versions without Self_ID for soft links
96 procedure Abort_Undefer
;
97 -- NON-INLINE versions without Self_ID for soft links
100 -- Locks out other tasks. Preceding a section of code by Task_Lock and
101 -- following it by Task_Unlock creates a critical region. This is used
102 -- for ensuring that a region of non-tasking code (such as code used to
103 -- allocate memory) is tasking safe. Note that it is valid for calls to
104 -- Task_Lock/Task_Unlock to be nested, and this must work properly, i.e.
105 -- only the corresponding outer level Task_Unlock will actually unlock.
107 procedure Task_Unlock
;
108 -- Releases lock previously set by call to Task_Lock. In the nested case,
109 -- all nested locks must be released before other tasks competing for the
110 -- tasking lock are released.
112 function Get_Stack_Info
return Stack_Checking
.Stack_Access
;
113 -- Get access to the current task's Stack_Info
115 procedure Update_Exception
116 (X
: AE
.Exception_Occurrence
:= Current_Target_Exception
);
117 -- Handle exception setting and check for pending actions
119 function Task_Name
return String;
120 -- Returns current task's name
122 ------------------------
123 -- Local Subprograms --
124 ------------------------
126 ----------------------------
127 -- Tasking Initialization --
128 ----------------------------
130 procedure Gnat_Install_Locks
(Lock
, Unlock
: SSL
.No_Param_Proc
);
131 pragma Import
(C
, Gnat_Install_Locks
, "__gnatlib_install_locks");
132 -- Used by Init_RTS to install procedure Lock and Unlock for the
133 -- thread locking. This has no effect on GCC 2. For GCC 3,
134 -- it has an effect only if gcc is configured with
135 -- --enable_threads=gnat.
138 -- This procedure completes the initialization of the GNARL. The first
139 -- part of the initialization is done in the body of System.Tasking.
140 -- It consists of initializing global locks, and installing tasking
141 -- versions of certain operations used by the compiler. Init_RTS is called
142 -- during elaboration.
144 --------------------------
145 -- Change_Base_Priority --
146 --------------------------
148 -- Call only with abort deferred and holding Self_ID locked
150 procedure Change_Base_Priority
(T
: Task_Id
) is
152 if T
.Common
.Base_Priority
/= T
.New_Base_Priority
then
153 T
.Common
.Base_Priority
:= T
.New_Base_Priority
;
154 Set_Priority
(T
, T
.Common
.Base_Priority
);
156 end Change_Base_Priority
;
158 ------------------------
159 -- Check_Abort_Status --
160 ------------------------
162 function Check_Abort_Status
return Integer is
163 Self_ID
: constant Task_Id
:= Self
;
165 if Self_ID
/= null and then Self_ID
.Deferral_Level
= 0
166 and then Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
172 end Check_Abort_Status
;
178 procedure Defer_Abort
(Self_ID
: Task_Id
) is
180 if No_Abort
and then not Dynamic_Priority_Support
then
184 pragma Assert
(Self_ID
.Deferral_Level
= 0);
187 -- (Self_ID.Pending_ATC_Level >= Self_ID.ATC_Nesting_Level);
189 -- The above check has been useful in detecting mismatched defer/undefer
190 -- pairs. You may uncomment it when testing on systems that support
193 -- If the OS supports preemptive abort (e.g. pthread_kill), it should
194 -- have happened already. A problem is with systems that do not support
195 -- preemptive abort, and so rely on polling. On such systems we may get
196 -- false failures of the assertion, since polling for pending abort does
197 -- no occur until the abort undefer operation.
199 -- Even on systems that only poll for abort, the assertion may be useful
200 -- for catching missed abort completion polling points. The operations
201 -- that undefer abort poll for pending aborts. This covers most of the
202 -- places where the core Ada semantics require abort to be caught,
203 -- without any special attention. However, this generally happens on
204 -- exit from runtime system call, which means a pending abort will not
205 -- be noticed on the way into the runtime system. We considered adding a
206 -- check for pending aborts at this point, but chose not to, because of
207 -- the overhead. Instead, we searched for RTS calls where abort
208 -- completion is required and a task could go farther than Ada allows
209 -- before undeferring abort; we then modified the code to ensure the
210 -- abort would be detected.
212 Self_ID
.Deferral_Level
:= Self_ID
.Deferral_Level
+ 1;
215 --------------------------
216 -- Defer_Abort_Nestable --
217 --------------------------
219 procedure Defer_Abort_Nestable
(Self_ID
: Task_Id
) is
221 if No_Abort
and then not Dynamic_Priority_Support
then
226 -- ((Self_ID.Pending_ATC_Level >= Self_ID.ATC_Nesting_Level or else
227 -- Self_ID.Deferral_Level > 0));
229 -- See comment in Defer_Abort on the situations in which it may be
230 -- useful to uncomment the above assertion.
232 Self_ID
.Deferral_Level
:= Self_ID
.Deferral_Level
+ 1;
233 end Defer_Abort_Nestable
;
239 procedure Abort_Defer
is
242 if No_Abort
and then not Dynamic_Priority_Support
then
246 Self_ID
:= STPO
.Self
;
247 Self_ID
.Deferral_Level
:= Self_ID
.Deferral_Level
+ 1;
250 -----------------------
251 -- Do_Pending_Action --
252 -----------------------
254 -- Call only when holding no locks
256 procedure Do_Pending_Action
(Self_ID
: Task_Id
) is
257 use type Ada
.Exceptions
.Exception_Id
;
260 pragma Assert
(Self_ID
= Self
and then Self_ID
.Deferral_Level
= 0);
262 -- Needs loop to recheck for pending action in case a new one occurred
263 -- while we had abort deferred below.
266 -- Temporarily defer abort so that we can lock Self_ID
268 Self_ID
.Deferral_Level
:= Self_ID
.Deferral_Level
+ 1;
274 Write_Lock
(Self_ID
);
275 Self_ID
.Pending_Action
:= False;
276 Poll_Base_Priority_Change
(Self_ID
);
283 -- Restore the original Deferral value
285 Self_ID
.Deferral_Level
:= Self_ID
.Deferral_Level
- 1;
287 if not Self_ID
.Pending_Action
then
288 if Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
then
289 if not Self_ID
.Aborting
then
290 Self_ID
.Aborting
:= True;
292 (Debug
.Trace
(Self_ID
, "raise Abort_Signal", 'B'));
293 raise Standard
'Abort_Signal;
295 pragma Assert
(not Self_ID
.ATC_Hack
);
297 elsif Self_ID
.ATC_Hack
then
298 -- The solution really belongs in the Abort_Signal handler
299 -- for async. entry calls. The present hack is very
300 -- fragile. It relies that the very next point after
301 -- Exit_One_ATC_Level at which the task becomes abortable
302 -- will be the call to Undefer_Abort in the
303 -- Abort_Signal handler.
305 Self_ID
.ATC_Hack
:= False;
309 (Self_ID
, "raise Abort_Signal (ATC hack)", 'B'));
310 raise Standard
'Abort_Signal;
317 end Do_Pending_Action
;
319 -----------------------
320 -- Final_Task_Unlock --
321 -----------------------
323 -- This version is only for use in Terminate_Task, when the task
324 -- is relinquishing further rights to its own ATCB.
325 -- There is a very interesting potential race condition there, where
326 -- the old task may run concurrently with a new task that is allocated
327 -- the old tasks (now reused) ATCB. The critical thing here is to
328 -- not make any reference to the ATCB after the lock is released.
329 -- See also comments on Terminate_Task and Unlock.
331 procedure Final_Task_Unlock
(Self_ID
: Task_Id
) is
333 pragma Assert
(Self_ID
.Global_Task_Lock_Nesting
= 1);
334 Unlock
(Global_Task_Lock
'Access, Global_Lock
=> True);
335 end Final_Task_Unlock
;
341 procedure Init_RTS
is
346 -- Terminate run time (regular vs restricted) specific initialization
347 -- of the environment task.
349 Self_Id
:= Environment_Task
;
350 Self_Id
.Master_of_Task
:= Environment_Task_Level
;
351 Self_Id
.Master_Within
:= Self_Id
.Master_of_Task
+ 1;
353 for L
in Self_Id
.Entry_Calls
'Range loop
354 Self_Id
.Entry_Calls
(L
).Self
:= Self_Id
;
355 Self_Id
.Entry_Calls
(L
).Level
:= L
;
358 Self_Id
.Awake_Count
:= 1;
359 Self_Id
.Alive_Count
:= 1;
361 Self_Id
.Master_Within
:= Library_Task_Level
;
362 -- Normally, a task starts out with internal master nesting level
363 -- one larger than external master nesting level. It is incremented
364 -- to one by Enter_Master, which is called in the task body only if
365 -- the compiler thinks the task may have dependent tasks. There is no
366 -- corresponding call to Enter_Master for the environment task, so we
367 -- would need to increment it to 2 here. Instead, we set it to 3.
368 -- By doing this we reserve the level 2 for server tasks of the runtime
369 -- system. The environment task does not need to wait for these server
371 -- Initialize lock used to implement mutual exclusion between all tasks
373 Initialize_Lock
(Global_Task_Lock
'Access, STPO
.Global_Task_Level
);
375 -- Notify that the tasking run time has been elaborated so that
376 -- the tasking version of the soft links can be used.
378 if not No_Abort
or else Dynamic_Priority_Support
then
379 SSL
.Abort_Defer
:= Abort_Defer
'Access;
380 SSL
.Abort_Undefer
:= Abort_Undefer
'Access;
383 SSL
.Update_Exception
:= Update_Exception
'Access;
384 SSL
.Lock_Task
:= Task_Lock
'Access;
385 SSL
.Unlock_Task
:= Task_Unlock
'Access;
386 SSL
.Check_Abort_Status
:= Check_Abort_Status
'Access;
387 SSL
.Get_Stack_Info
:= Get_Stack_Info
'Access;
388 SSL
.Task_Name
:= Task_Name
'Access;
390 -- Initialize the tasking soft links (if not done yet) that are common
391 -- to the full and the restricted run times.
393 SSL
.Tasking
.Init_Tasking_Soft_Links
;
395 -- Install tasking locks in the GCC runtime
397 Gnat_Install_Locks
(Task_Lock
'Access, Task_Unlock
'Access);
399 -- Abort is deferred in a new ATCB, so we need to undefer abort
400 -- at this stage to make the environment task abortable.
402 Undefer_Abort
(Environment_Task
);
405 ---------------------------
406 -- Locked_Abort_To_Level--
407 ---------------------------
409 -- Abort a task to the specified ATC nesting level.
410 -- Call this only with T locked.
412 -- An earlier version of this code contained a call to Wakeup. That
413 -- should not be necessary here, if Abort_Task is implemented correctly,
414 -- since Abort_Task should include the effect of Wakeup. However, the
415 -- above call was in earlier versions of this file, and at least for
416 -- some targets Abort_Task has not beek doing Wakeup. It should not
417 -- hurt to uncomment the above call, until the error is corrected for
420 -- See extended comments in package body System.Tasking.Abort for the
421 -- overall design of the implementation of task abort.
422 -- ??? there is no such package ???
424 -- If the task is sleeping it will be in an abort-deferred region, and
425 -- will not have Abort_Signal raised by Abort_Task. Such an "abort
426 -- deferral" is just to protect the RTS internals, and not necessarily
427 -- required to enforce Ada semantics. Abort_Task should wake the task up
428 -- and let it decide if it wants to complete the aborted construct
431 -- Note that the effect of the lowl-level Abort_Task is not persistent.
432 -- If the target task is not blocked, this wakeup will be missed.
434 -- We don't bother calling Abort_Task if this task is aborting itself,
435 -- since we are inside the RTS and have abort deferred. Similarly, We
436 -- don't bother to call Abort_Task if T is terminated, since there is
437 -- no need to abort a terminated task, and it could be dangerous to try
438 -- if the task has stopped executing.
440 -- Note that an earlier version of this code had some false reasoning
441 -- about being able to reliably wake up a task that had suspended on
442 -- a blocking system call that does not atomically relase the task's
443 -- lock (e.g., UNIX nanosleep, which we once thought could be used to
444 -- implement delays). That still left the possibility of missed
447 -- We cannot safely call Vulnerable_Complete_Activation here, since that
448 -- requires locking Self_ID.Parent. The anti-deadlock lock ordering rules
449 -- would then require us to release the lock on Self_ID first, which would
450 -- create a timing window for other tasks to lock Self_ID. This is
451 -- significant for tasks that may be aborted before their execution can
452 -- enter the task body, and so they do not get a chance to call
453 -- Complete_Task. The actual work for this case is done in Terminate_Task.
455 procedure Locked_Abort_To_Level
461 if not T
.Aborting
and then T
/= Self_ID
then
462 case T
.Common
.State
is
463 when Unactivated | Terminated
=>
464 pragma Assert
(False);
468 -- This is needed to cancel an asynchronous protected entry
469 -- call during a requeue with abort.
472 (T
.ATC_Nesting_Level
).Cancellation_Attempted
:= True;
474 when Interrupt_Server_Blocked_On_Event_Flag
=>
479 Interrupt_Server_Idle_Sleep |
480 Interrupt_Server_Blocked_Interrupt_Sleep |
483 Wakeup
(T
, T
.Common
.State
);
485 when Acceptor_Sleep
=>
486 T
.Open_Accepts
:= null;
487 Wakeup
(T
, T
.Common
.State
);
489 when Entry_Caller_Sleep
=>
491 (T
.ATC_Nesting_Level
).Cancellation_Attempted
:= True;
492 Wakeup
(T
, T
.Common
.State
);
494 when Activator_Sleep |
495 Master_Completion_Sleep |
496 Master_Phase_2_Sleep |
502 if T
.Pending_ATC_Level
> L
then
503 T
.Pending_ATC_Level
:= L
;
504 T
.Pending_Action
:= True;
510 -- This prevents aborted task from accepting calls
514 -- The test above is just a heuristic, to reduce wasteful
515 -- calls to Abort_Task. We are holding T locked, and this
516 -- value will not be set to False except with T also locked,
517 -- inside Exit_One_ATC_Level, so we should not miss wakeups.
519 if T
.Common
.State
= Acceptor_Sleep
then
520 T
.Open_Accepts
:= null;
523 elsif T
/= Self_ID
and then
524 (T
.Common
.State
= Runnable
525 or else T
.Common
.State
= Interrupt_Server_Blocked_On_Event_Flag
)
526 -- The task is blocked on a system call waiting for the
527 -- completion event. In this case Abort_Task may need to take
528 -- special action in order to succeed. Example system: VMS.
534 end Locked_Abort_To_Level
;
536 -------------------------------
537 -- Poll_Base_Priority_Change --
538 -------------------------------
540 -- Poll for pending base priority change and for held tasks.
541 -- This should always be called with (only) Self_ID locked.
542 -- It may temporarily release Self_ID's lock.
544 -- The call to Yield is to force enqueuing at the
545 -- tail of the dispatching queue.
547 -- We must unlock Self_ID for this to take effect,
548 -- since we are inheriting high active priority from the lock.
550 -- See also Poll_Base_Priority_Change_At_Entry_Call,
551 -- in package System.Tasking.Entry_Calls.
553 -- In this version, we check if the task is held too because
554 -- doing this only in Do_Pending_Action is not enough.
556 procedure Poll_Base_Priority_Change
(Self_ID
: Task_Id
) is
558 if Dynamic_Priority_Support
and then Self_ID
.Pending_Priority_Change
then
560 -- Check for ceiling violations ???
562 Self_ID
.Pending_Priority_Change
:= False;
564 if Self_ID
.Common
.Base_Priority
= Self_ID
.New_Base_Priority
then
572 Write_Lock
(Self_ID
);
575 elsif Self_ID
.Common
.Base_Priority
< Self_ID
.New_Base_Priority
then
576 Self_ID
.Common
.Base_Priority
:= Self_ID
.New_Base_Priority
;
577 Set_Priority
(Self_ID
, Self_ID
.Common
.Base_Priority
);
582 Self_ID
.Common
.Base_Priority
:= Self_ID
.New_Base_Priority
;
583 Set_Priority
(Self_ID
, Self_ID
.Common
.Base_Priority
);
592 Write_Lock
(Self_ID
);
596 end Poll_Base_Priority_Change
;
598 --------------------------------
599 -- Remove_From_All_Tasks_List --
600 --------------------------------
602 procedure Remove_From_All_Tasks_List
(T
: Task_Id
) is
608 (Debug
.Trace
(Self
, "Remove_From_All_Tasks_List", 'C'));
610 Previous
:= Null_Task
;
613 while C
/= Null_Task
loop
615 if Previous
= Null_Task
then
617 All_Tasks_List
.Common
.All_Tasks_Link
;
619 Previous
.Common
.All_Tasks_Link
:= C
.Common
.All_Tasks_Link
;
626 C
:= C
.Common
.All_Tasks_Link
;
629 pragma Assert
(False);
630 end Remove_From_All_Tasks_List
;
636 procedure Task_Lock
(Self_ID
: Task_Id
) is
638 Self_ID
.Global_Task_Lock_Nesting
:= Self_ID
.Global_Task_Lock_Nesting
+ 1;
640 if Self_ID
.Global_Task_Lock_Nesting
= 1 then
641 Defer_Abort_Nestable
(Self_ID
);
642 Write_Lock
(Global_Task_Lock
'Access, Global_Lock
=> True);
646 procedure Task_Lock
is
648 Task_Lock
(STPO
.Self
);
655 function Task_Name
return String is
656 Self_Id
: constant Task_Id
:= STPO
.Self
;
659 return Self_Id
.Common
.Task_Image
(1 .. Self_Id
.Common
.Task_Image_Len
);
666 procedure Task_Unlock
(Self_ID
: Task_Id
) is
668 pragma Assert
(Self_ID
.Global_Task_Lock_Nesting
> 0);
669 Self_ID
.Global_Task_Lock_Nesting
:= Self_ID
.Global_Task_Lock_Nesting
- 1;
671 if Self_ID
.Global_Task_Lock_Nesting
= 0 then
672 Unlock
(Global_Task_Lock
'Access, Global_Lock
=> True);
673 Undefer_Abort_Nestable
(Self_ID
);
677 procedure Task_Unlock
is
679 Task_Unlock
(STPO
.Self
);
686 -- Precondition : Self does not hold any locks!
688 -- Undefer_Abort is called on any abort completion point (aka.
689 -- synchronization point). It performs the following actions if they
690 -- are pending: (1) change the base priority, (2) abort the task.
692 -- The priority change has to occur before abort. Otherwise, it would
693 -- take effect no earlier than the next abort completion point.
695 procedure Undefer_Abort
(Self_ID
: Task_Id
) is
697 if No_Abort
and then not Dynamic_Priority_Support
then
701 pragma Assert
(Self_ID
.Deferral_Level
= 1);
703 Self_ID
.Deferral_Level
:= Self_ID
.Deferral_Level
- 1;
705 if Self_ID
.Deferral_Level
= 0 then
706 pragma Assert
(Check_No_Locks
(Self_ID
));
708 if Self_ID
.Pending_Action
then
709 Do_Pending_Action
(Self_ID
);
714 ----------------------------
715 -- Undefer_Abort_Nestable --
716 ----------------------------
718 -- An earlier version would re-defer abort if an abort is in progress.
719 -- Then, we modified the effect of the raise statement so that it defers
720 -- abort until control reaches a handler. That was done to prevent
721 -- "skipping over" a handler if another asynchronous abort occurs during
722 -- the propagation of the abort to the handler.
724 -- There has been talk of reversing that decision, based on a newer
725 -- implementation of exception propagation. Care must be taken to evaluate
726 -- how such a change would interact with the above code and all the places
727 -- where abort-deferral is used to bridge over critical transitions, such
728 -- as entry to the scope of a region with a finalizer and entry into the
729 -- body of an accept-procedure.
731 procedure Undefer_Abort_Nestable
(Self_ID
: Task_Id
) is
733 if No_Abort
and then not Dynamic_Priority_Support
then
737 pragma Assert
(Self_ID
.Deferral_Level
> 0);
739 Self_ID
.Deferral_Level
:= Self_ID
.Deferral_Level
- 1;
741 if Self_ID
.Deferral_Level
= 0 then
743 pragma Assert
(Check_No_Locks
(Self_ID
));
745 if Self_ID
.Pending_Action
then
746 Do_Pending_Action
(Self_ID
);
749 end Undefer_Abort_Nestable
;
755 procedure Abort_Undefer
is
758 if No_Abort
and then not Dynamic_Priority_Support
then
762 Self_ID
:= STPO
.Self
;
764 if Self_ID
.Deferral_Level
= 0 then
766 -- In case there are different views on whether Abort is supported
767 -- between the expander and the run time, we may end up with
768 -- Self_ID.Deferral_Level being equal to zero, when called from
769 -- the procedure created by the expander that corresponds to a
772 -- In this case, there's nothing to be done
774 -- See related code in System.Tasking.Stages.Create_Task resetting
775 -- Deferral_Level when System.Restrictions.Abort_Allowed is False.
780 pragma Assert
(Self_ID
.Deferral_Level
> 0);
781 Self_ID
.Deferral_Level
:= Self_ID
.Deferral_Level
- 1;
783 if Self_ID
.Deferral_Level
= 0 then
784 pragma Assert
(Check_No_Locks
(Self_ID
));
786 if Self_ID
.Pending_Action
then
787 Do_Pending_Action
(Self_ID
);
792 ----------------------
793 -- Update_Exception --
794 ----------------------
796 -- Call only when holding no locks
798 procedure Update_Exception
799 (X
: AE
.Exception_Occurrence
:= Current_Target_Exception
)
801 Self_Id
: constant Task_Id
:= Self
;
805 Save_Occurrence
(Self_Id
.Common
.Compiler_Data
.Current_Excep
, X
);
807 if Self_Id
.Deferral_Level
= 0 then
808 if Self_Id
.Pending_Action
then
809 Self_Id
.Pending_Action
:= False;
810 Self_Id
.Deferral_Level
:= Self_Id
.Deferral_Level
+ 1;
816 Write_Lock
(Self_Id
);
817 Self_Id
.Pending_Action
:= False;
818 Poll_Base_Priority_Change
(Self_Id
);
825 Self_Id
.Deferral_Level
:= Self_Id
.Deferral_Level
- 1;
827 if Self_Id
.Pending_ATC_Level
< Self_Id
.ATC_Nesting_Level
then
828 if not Self_Id
.Aborting
then
829 Self_Id
.Aborting
:= True;
830 raise Standard
'Abort_Signal;
835 end Update_Exception
;
837 --------------------------
838 -- Wakeup_Entry_Caller --
839 --------------------------
841 -- This is called at the end of service of an entry call, to abort the
842 -- caller if he is in an abortable part, and to wake up the caller if it
843 -- is on Entry_Caller_Sleep. It assumes that the call is already off-queue.
845 -- (This enforces the rule that a task must be off-queue if its state is
846 -- Done or Cancelled.) Call it holding the lock of Entry_Call.Self.
848 -- Timed_Call or Simple_Call:
849 -- The caller is waiting on Entry_Caller_Sleep, in
850 -- Wait_For_Completion, or Wait_For_Completion_With_Timeout.
853 -- The caller might be in Wait_For_Completion,
854 -- waiting for a rendezvous (possibly requeued without abort)
857 -- Asynchronous_Call:
858 -- The caller may be executing in the abortable part o
859 -- an async. select, or on a time delay,
860 -- if Entry_Call.State >= Was_Abortable.
862 procedure Wakeup_Entry_Caller
864 Entry_Call
: Entry_Call_Link
;
865 New_State
: Entry_Call_State
)
867 Caller
: constant Task_Id
:= Entry_Call
.Self
;
870 pragma Debug
(Debug
.Trace
871 (Self_ID
, "Wakeup_Entry_Caller", 'E', Caller
));
872 pragma Assert
(New_State
= Done
or else New_State
= Cancelled
);
875 (Caller
.Common
.State
/= Terminated
876 and then Caller
.Common
.State
/= Unactivated
);
878 Entry_Call
.State
:= New_State
;
880 if Entry_Call
.Mode
= Asynchronous_Call
then
882 -- Abort the caller in his abortable part,
883 -- but do so only if call has been queued abortably
885 if Entry_Call
.State
>= Was_Abortable
or else New_State
= Done
then
886 Locked_Abort_To_Level
(Self_ID
, Caller
, Entry_Call
.Level
- 1);
889 elsif Caller
.Common
.State
= Entry_Caller_Sleep
then
890 Wakeup
(Caller
, Entry_Caller_Sleep
);
892 end Wakeup_Entry_Caller
;
894 ----------------------
895 -- Soft-Link Bodies --
896 ----------------------
898 function Get_Stack_Info
return Stack_Checking
.Stack_Access
is
900 return STPO
.Self
.Common
.Compiler_Data
.Pri_Stack_Info
'Access;
903 -----------------------
904 -- Soft-Link Dummies --
905 -----------------------
907 -- These are dummies for subprograms that are only needed by certain
908 -- optional run-time system packages. If they are needed, the soft
909 -- links will be redirected to the real subprogram by elaboration of
910 -- the subprogram body where the real subprogram is declared.
912 procedure Finalize_Attributes
(T
: Task_Id
) is
913 pragma Warnings
(Off
, T
);
917 end Finalize_Attributes
;
919 procedure Initialize_Attributes
(T
: Task_Id
) is
920 pragma Warnings
(Off
, T
);
924 end Initialize_Attributes
;
928 end System
.Tasking
.Initialization
;