1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- S Y S T E M . T A S K I N G . R E S T R I C T E D . S T A G E S --
9 -- Copyright (C) 1999-2008, 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 order check, since we group soft link
36 -- bodies and also separate off subprograms for restricted GNARLI.
38 -- This is a simplified version of the System.Tasking.Stages package,
39 -- intended to be used in a restricted run time.
41 -- This package represents the high level tasking interface used by the
42 -- compiler to expand Ada 95 tasking constructs into simpler run time calls.
45 -- Turn off polling, we do not want ATC polling to take place during
46 -- tasking operations. It causes infinite loops and other problems.
50 with System
.Task_Primitives
.Operations
;
51 with System
.Soft_Links
.Tasking
;
52 with System
.Secondary_Stack
;
53 with System
.Storage_Elements
;
55 with System
.Soft_Links
;
56 -- Used for the non-tasking routines (*_NT) that refer to global data. They
57 -- are needed here before the tasking run time has been elaborated. used for
58 -- Create_TSD This package also provides initialization routines for task
59 -- specific data. The GNARL must call these to be sure that all non-tasking
60 -- Ada constructs will work.
62 package body System
.Tasking
.Restricted
.Stages
is
64 package STPO
renames System
.Task_Primitives
.Operations
;
65 package SSL
renames System
.Soft_Links
;
66 package SSE
renames System
.Storage_Elements
;
67 package SST
renames System
.Secondary_Stack
;
72 use Task_Primitives
.Operations
;
75 Global_Task_Lock
: aliased System
.Task_Primitives
.RTS_Lock
;
76 -- This is a global lock; it is used to execute in mutual exclusion
77 -- from all other tasks. It is only used by Task_Lock and Task_Unlock.
79 -----------------------------------------------------------------
80 -- Tasking versions of services needed by non-tasking programs --
81 -----------------------------------------------------------------
83 function Get_Current_Excep
return SSL
.EOA
;
84 -- Task-safe version of SSL.Get_Current_Excep
87 -- Locks out other tasks. Preceding a section of code by Task_Lock and
88 -- following it by Task_Unlock creates a critical region. This is used
89 -- for ensuring that a region of non-tasking code (such as code used to
90 -- allocate memory) is tasking safe. Note that it is valid for calls to
91 -- Task_Lock/Task_Unlock to be nested, and this must work properly, i.e.
92 -- only the corresponding outer level Task_Unlock will actually unlock.
94 procedure Task_Unlock
;
95 -- Releases lock previously set by call to Task_Lock. In the nested case,
96 -- all nested locks must be released before other tasks competing for the
97 -- tasking lock are released.
99 -----------------------
100 -- Local Subprograms --
101 -----------------------
103 procedure Task_Wrapper
(Self_ID
: Task_Id
);
104 -- This is the procedure that is called by the GNULL from the
105 -- new context when a task is created. It waits for activation
106 -- and then calls the task body procedure. When the task body
107 -- procedure completes, it terminates the task.
109 procedure Terminate_Task
(Self_ID
: Task_Id
);
110 -- Terminate the calling task.
111 -- This should only be called by the Task_Wrapper procedure.
114 -- This procedure performs the initialization of the GNARL.
115 -- It consists of initializing the environment task, global locks, and
116 -- installing tasking versions of certain operations used by the compiler.
117 -- Init_RTS is called during elaboration.
119 -----------------------
120 -- Get_Current_Excep --
121 -----------------------
123 function Get_Current_Excep
return SSL
.EOA
is
125 return STPO
.Self
.Common
.Compiler_Data
.Current_Excep
'Access;
126 end Get_Current_Excep
;
132 procedure Task_Lock
is
133 Self_ID
: constant Task_Id
:= STPO
.Self
;
136 Self_ID
.Common
.Global_Task_Lock_Nesting
:=
137 Self_ID
.Common
.Global_Task_Lock_Nesting
+ 1;
139 if Self_ID
.Common
.Global_Task_Lock_Nesting
= 1 then
140 STPO
.Write_Lock
(Global_Task_Lock
'Access, Global_Lock
=> True);
148 procedure Task_Unlock
is
149 Self_ID
: constant Task_Id
:= STPO
.Self
;
152 pragma Assert
(Self_ID
.Common
.Global_Task_Lock_Nesting
> 0);
153 Self_ID
.Common
.Global_Task_Lock_Nesting
:=
154 Self_ID
.Common
.Global_Task_Lock_Nesting
- 1;
156 if Self_ID
.Common
.Global_Task_Lock_Nesting
= 0 then
157 STPO
.Unlock
(Global_Task_Lock
'Access, Global_Lock
=> True);
165 -- The task wrapper is a procedure that is called first for each task
166 -- task body, and which in turn calls the compiler-generated task body
167 -- procedure. The wrapper's main job is to do initialization for the task.
169 -- The variable ID in the task wrapper is used to implement the Self
170 -- function on targets where there is a fast way to find the stack base
171 -- of the current thread, since it should be at a fixed offset from the
174 procedure Task_Wrapper
(Self_ID
: Task_Id
) is
175 ID
: Task_Id
:= Self_ID
;
176 pragma Volatile
(ID
);
177 pragma Warnings
(Off
, ID
);
178 -- Variable used on some targets to implement a fast self. We turn off
179 -- warnings because a stand alone volatile constant has to be imported,
180 -- so we don't want warnings about ID not being referenced, and volatile
183 -- DO NOT delete ID. As noted, it is needed on some targets.
185 use type SSE
.Storage_Offset
;
187 Secondary_Stack
: aliased SSE
.Storage_Array
188 (1 .. Self_ID
.Common
.Compiler_Data
.Pri_Stack_Info
.Size
*
189 SSE
.Storage_Offset
(Parameters
.Sec_Stack_Ratio
) / 100);
191 pragma Warnings
(Off
);
192 Secondary_Stack_Address
: System
.Address
:= Secondary_Stack
'Address;
193 pragma Warnings
(On
);
194 -- Address of secondary stack. In the fixed secondary stack case, this
195 -- value is not modified, causing a warning, hence the bracketing with
196 -- Warnings (Off/On).
198 Cause
: Cause_Of_Termination
:= Normal
;
199 -- Indicates the reason why this task terminates. Normal corresponds to
200 -- a task terminating due to completing the last statement of its body.
201 -- If the task terminates because of an exception raised by the
202 -- execution of its task body, then Cause is set to Unhandled_Exception.
203 -- Aborts are not allowed in the restricted profile to which this file
206 EO
: Exception_Occurrence
;
207 -- If the task terminates because of an exception raised by the
208 -- execution of its task body, then EO will contain the associated
209 -- exception occurrence. Otherwise, it will contain Null_Occurrence.
212 if not Parameters
.Sec_Stack_Dynamic
then
213 Self_ID
.Common
.Compiler_Data
.Sec_Stack_Addr
:=
214 Secondary_Stack
'Address;
215 SST
.SS_Init
(Secondary_Stack_Address
, Integer (Secondary_Stack
'Last));
218 -- Initialize low-level TCB components, that
219 -- cannot be initialized by the creator.
221 Enter_Task
(Self_ID
);
223 -- Call the task body procedure
226 -- We are separating the following portion of the code in order to
227 -- place the exception handlers in a different block. In this way we
228 -- do not call Set_Jmpbuf_Address (which needs Self) before we set
229 -- Self in Enter_Task.
231 -- Note that in the case of Ravenscar HI-E where there are no
232 -- exception handlers, the exception handler is suppressed.
234 -- Call the task body procedure
236 Self_ID
.Common
.Task_Entry_Point
(Self_ID
.Common
.Task_Arg
);
238 -- Normal task termination
241 Save_Occurrence
(EO
, Ada
.Exceptions
.Null_Occurrence
);
246 -- Task terminating because of an unhandled exception
248 Cause
:= Unhandled_Exception
;
249 Save_Occurrence
(EO
, E
);
252 -- Look for a fall-back handler. It can be either in the task itself
253 -- or in the environment task. Note that this code is always executed
254 -- by a task whose master is the environment task. The task termination
255 -- code for the environment task is executed by
256 -- SSL.Task_Termination_Handler.
258 -- This package is part of the restricted run time which supports
259 -- neither task hierarchies (No_Task_Hierarchy) nor specific task
260 -- termination handlers (No_Specific_Termination_Handlers).
262 -- There is no need for explicit protection against race conditions
263 -- for Self_ID.Common.Fall_Back_Handler because this procedure can
264 -- only be executed by Self, and the Fall_Back_Handler can only be
267 if Self_ID
.Common
.Fall_Back_Handler
/= null then
268 Self_ID
.Common
.Fall_Back_Handler
(Cause
, Self_ID
, EO
);
271 TH
: Termination_Handler
:= null;
278 Write_Lock
(Self_ID
.Common
.Parent
);
280 TH
:= Self_ID
.Common
.Parent
.Common
.Fall_Back_Handler
;
282 Unlock
(Self_ID
.Common
.Parent
);
288 -- Execute the task termination handler if we found it
291 TH
.all (Cause
, Self_ID
, EO
);
296 Terminate_Task
(Self_ID
);
299 -----------------------
300 -- Restricted GNARLI --
301 -----------------------
303 -------------------------------
304 -- Activate_Restricted_Tasks --
305 -------------------------------
307 -- Note that locks of activator and activated task are both locked here.
308 -- This is necessary because C.State and Self.Wait_Count have to be
309 -- synchronized. This is safe from deadlock because the activator is always
310 -- created before the activated task. That satisfies our
311 -- in-order-of-creation ATCB locking policy.
313 procedure Activate_Restricted_Tasks
314 (Chain_Access
: Activation_Chain_Access
)
316 Self_ID
: constant Task_Id
:= STPO
.Self
;
318 Activate_Prio
: System
.Any_Priority
;
322 pragma Assert
(Self_ID
= Environment_Task
);
323 pragma Assert
(Self_ID
.Common
.Wait_Count
= 0);
329 -- Lock self, to prevent activated tasks from racing ahead before we
330 -- finish activating the chain.
332 Write_Lock
(Self_ID
);
334 -- Activate all the tasks in the chain. Creation of the thread of
335 -- control was deferred until activation. So create it now.
337 C
:= Chain_Access
.T_ID
;
340 if C
.Common
.State
/= Terminated
then
341 pragma Assert
(C
.Common
.State
= Unactivated
);
345 if C
.Common
.Base_Priority
< Get_Priority
(Self_ID
) then
346 Activate_Prio
:= Get_Priority
(Self_ID
);
348 Activate_Prio
:= C
.Common
.Base_Priority
;
352 (C
, Task_Wrapper
'Address,
354 (C
.Common
.Compiler_Data
.Pri_Stack_Info
.Size
),
355 Activate_Prio
, Success
);
357 Self_ID
.Common
.Wait_Count
:= Self_ID
.Common
.Wait_Count
+ 1;
360 C
.Common
.State
:= Runnable
;
368 C
:= C
.Common
.Activation_Link
;
371 Self_ID
.Common
.State
:= Activator_Sleep
;
373 -- Wait for the activated tasks to complete activation. It is unsafe to
374 -- abort any of these tasks until the count goes to zero.
377 exit when Self_ID
.Common
.Wait_Count
= 0;
378 Sleep
(Self_ID
, Activator_Sleep
);
381 Self_ID
.Common
.State
:= Runnable
;
388 -- Remove the tasks from the chain
390 Chain_Access
.T_ID
:= null;
391 end Activate_Restricted_Tasks
;
393 ------------------------------------
394 -- Complete_Restricted_Activation --
395 ------------------------------------
397 -- As in several other places, the locks of the activator and activated
398 -- task are both locked here. This follows our deadlock prevention lock
399 -- ordering policy, since the activated task must be created after the
402 procedure Complete_Restricted_Activation
is
403 Self_ID
: constant Task_Id
:= STPO
.Self
;
404 Activator
: constant Task_Id
:= Self_ID
.Common
.Activator
;
411 Write_Lock
(Activator
);
412 Write_Lock
(Self_ID
);
414 -- Remove dangling reference to Activator, since a task may outlive its
417 Self_ID
.Common
.Activator
:= null;
419 -- Wake up the activator, if it is waiting for a chain of tasks to
420 -- activate, and we are the last in the chain to complete activation
422 if Activator
.Common
.State
= Activator_Sleep
then
423 Activator
.Common
.Wait_Count
:= Activator
.Common
.Wait_Count
- 1;
425 if Activator
.Common
.Wait_Count
= 0 then
426 Wakeup
(Activator
, Activator_Sleep
);
437 -- After the activation, active priority should be the same as base
438 -- priority. We must unlock the Activator first, though, since it should
439 -- not wait if we have lower priority.
441 if Get_Priority
(Self_ID
) /= Self_ID
.Common
.Base_Priority
then
442 Set_Priority
(Self_ID
, Self_ID
.Common
.Base_Priority
);
444 end Complete_Restricted_Activation
;
446 ------------------------------
447 -- Complete_Restricted_Task --
448 ------------------------------
450 procedure Complete_Restricted_Task
is
452 STPO
.Self
.Common
.State
:= Terminated
;
453 end Complete_Restricted_Task
;
455 ----------------------------
456 -- Create_Restricted_Task --
457 ----------------------------
459 procedure Create_Restricted_Task
461 Stack_Address
: System
.Address
;
462 Size
: System
.Parameters
.Size_Type
;
463 Task_Info
: System
.Task_Info
.Task_Info_Type
;
464 State
: Task_Procedure_Access
;
465 Discriminants
: System
.Address
;
466 Elaborated
: Access_Boolean
;
467 Chain
: in out Activation_Chain
;
469 Created_Task
: Task_Id
)
471 Self_ID
: constant Task_Id
:= STPO
.Self
;
472 Base_Priority
: System
.Any_Priority
;
477 -- Stack is not preallocated on this target, so that Stack_Address must
480 pragma Assert
(Stack_Address
= Null_Address
);
482 if Priority
= Unspecified_Priority
then
483 Base_Priority
:= Self_ID
.Common
.Base_Priority
;
485 Base_Priority
:= System
.Any_Priority
(Priority
);
492 Write_Lock
(Self_ID
);
494 -- With no task hierarchy, the parent of all non-Environment tasks that
495 -- are created must be the Environment task
498 (Self_ID
, State
, Discriminants
, Self_ID
, Elaborated
, Base_Priority
,
499 Task_Info
, Size
, Created_Task
, Success
);
501 -- If we do our job right then there should never be any failures, which
502 -- was probably said about the Titanic; so just to be safe, let's retain
515 Created_Task
.Entry_Calls
(1).Self
:= Created_Task
;
518 Integer'Min (Created_Task
.Common
.Task_Image
'Length, Task_Image
'Length);
519 Created_Task
.Common
.Task_Image_Len
:= Len
;
520 Created_Task
.Common
.Task_Image
(1 .. Len
) :=
521 Task_Image
(Task_Image
'First .. Task_Image
'First + Len
- 1);
529 -- Create TSD as early as possible in the creation of a task, since it
530 -- may be used by the operation of Ada code within the task.
532 SSL
.Create_TSD
(Created_Task
.Common
.Compiler_Data
);
533 Created_Task
.Common
.Activation_Link
:= Chain
.T_ID
;
534 Chain
.T_ID
:= Created_Task
;
535 end Create_Restricted_Task
;
537 ---------------------------
538 -- Finalize_Global_Tasks --
539 ---------------------------
541 -- This is needed to support the compiler interface; it will only be called
542 -- by the Environment task. Instead, it will cause the Environment to block
543 -- forever, since none of the dependent tasks are expected to terminate
545 procedure Finalize_Global_Tasks
is
546 Self_ID
: constant Task_Id
:= STPO
.Self
;
549 pragma Assert
(Self_ID
= STPO
.Environment_Task
);
555 -- Handle normal task termination by the environment task, but only for
556 -- the normal task termination. In the case of Abnormal and
557 -- Unhandled_Exception they must have been handled before, and the task
558 -- termination soft link must have been changed so the task termination
559 -- routine is not executed twice.
561 -- Note that in the "normal" implementation in s-tassta.adb the task
562 -- termination procedure for the environment task should be executed
563 -- after termination of library-level tasks. However, this
564 -- implementation is to be used when the Ravenscar restrictions are in
565 -- effect, and AI-394 says that if there is a fall-back handler set for
566 -- the partition it should be called when the first task (including the
567 -- environment task) attempts to terminate.
569 SSL
.Task_Termination_Handler
.all (Ada
.Exceptions
.Null_Occurrence
);
571 Write_Lock
(Self_ID
);
572 Sleep
(Self_ID
, Master_Completion_Sleep
);
579 -- Should never return from Master Completion Sleep
582 end Finalize_Global_Tasks
;
584 ---------------------------
585 -- Restricted_Terminated --
586 ---------------------------
588 function Restricted_Terminated
(T
: Task_Id
) return Boolean is
590 return T
.Common
.State
= Terminated
;
591 end Restricted_Terminated
;
597 procedure Terminate_Task
(Self_ID
: Task_Id
) is
599 Self_ID
.Common
.State
:= Terminated
;
606 procedure Init_RTS
is
610 -- Initialize lock used to implement mutual exclusion between all tasks
612 STPO
.Initialize_Lock
(Global_Task_Lock
'Access, STPO
.Global_Task_Level
);
614 -- Notify that the tasking run time has been elaborated so that
615 -- the tasking version of the soft links can be used.
617 SSL
.Lock_Task
:= Task_Lock
'Access;
618 SSL
.Unlock_Task
:= Task_Unlock
'Access;
619 SSL
.Adafinal
:= Finalize_Global_Tasks
'Access;
620 SSL
.Get_Current_Excep
:= Get_Current_Excep
'Access;
622 -- Initialize the tasking soft links (if not done yet) that are common
623 -- to the full and the restricted run times.
625 SSL
.Tasking
.Init_Tasking_Soft_Links
;
630 end System
.Tasking
.Restricted
.Stages
;