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-2014, 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 3, or (at your option) any later ver- --
14 -- sion. GNAT 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. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
30 ------------------------------------------------------------------------------
32 pragma Style_Checks
(All_Checks
);
33 -- Turn off subprogram alpha order check, since we group soft link
34 -- bodies and also separate off subprograms for restricted GNARLI.
36 -- This is a simplified version of the System.Tasking.Stages package,
37 -- intended to be used in a restricted run time.
39 -- This package represents the high level tasking interface used by the
40 -- compiler to expand Ada 95 tasking constructs into simpler run time calls.
43 -- Turn off polling, we do not want ATC polling to take place during
44 -- tasking operations. It causes infinite loops and other problems.
48 with System
.Task_Primitives
.Operations
;
49 with System
.Soft_Links
.Tasking
;
50 with System
.Storage_Elements
;
52 with System
.Secondary_Stack
;
53 pragma Elaborate_All
(System
.Secondary_Stack
);
54 -- Make sure the body of Secondary_Stack is elaborated before calling
55 -- Init_Tasking_Soft_Links. See comments for this routine for explanation.
57 with System
.Soft_Links
;
58 -- Used for the non-tasking routines (*_NT) that refer to global data. They
59 -- are needed here before the tasking run time has been elaborated. used for
60 -- Create_TSD This package also provides initialization routines for task
61 -- specific data. The GNARL must call these to be sure that all non-tasking
62 -- Ada constructs will work.
64 package body System
.Tasking
.Restricted
.Stages
is
66 package STPO
renames System
.Task_Primitives
.Operations
;
67 package SSL
renames System
.Soft_Links
;
68 package SSE
renames System
.Storage_Elements
;
69 package SST
renames System
.Secondary_Stack
;
74 use Task_Primitives
.Operations
;
77 Tasks_Activation_Chain
: Task_Id
;
78 -- Chain of all the tasks to activate
80 Global_Task_Lock
: aliased System
.Task_Primitives
.RTS_Lock
;
81 -- This is a global lock; it is used to execute in mutual exclusion
82 -- from all other tasks. It is only used by Task_Lock and Task_Unlock.
84 -----------------------------------------------------------------
85 -- Tasking versions of services needed by non-tasking programs --
86 -----------------------------------------------------------------
88 function Get_Current_Excep
return SSL
.EOA
;
89 -- Task-safe version of SSL.Get_Current_Excep
92 -- Locks out other tasks. Preceding a section of code by Task_Lock and
93 -- following it by Task_Unlock creates a critical region. This is used
94 -- for ensuring that a region of non-tasking code (such as code used to
95 -- allocate memory) is tasking safe. Note that it is valid for calls to
96 -- Task_Lock/Task_Unlock to be nested, and this must work properly, i.e.
97 -- only the corresponding outer level Task_Unlock will actually unlock.
99 procedure Task_Unlock
;
100 -- Releases lock previously set by call to Task_Lock. In the nested case,
101 -- all nested locks must be released before other tasks competing for the
102 -- tasking lock are released.
104 -----------------------
105 -- Local Subprograms --
106 -----------------------
108 procedure Task_Wrapper
(Self_ID
: Task_Id
);
109 -- This is the procedure that is called by the GNULL from the
110 -- new context when a task is created. It waits for activation
111 -- and then calls the task body procedure. When the task body
112 -- procedure completes, it terminates the task.
114 procedure Terminate_Task
(Self_ID
: Task_Id
);
115 -- Terminate the calling task.
116 -- This should only be called by the Task_Wrapper procedure.
118 procedure Create_Restricted_Task
120 Stack_Address
: System
.Address
;
121 Size
: System
.Parameters
.Size_Type
;
122 Task_Info
: System
.Task_Info
.Task_Info_Type
;
124 State
: Task_Procedure_Access
;
125 Discriminants
: System
.Address
;
126 Elaborated
: Access_Boolean
;
128 Created_Task
: Task_Id
);
129 -- Code shared between Create_Restricted_Task (the concurrent version) and
130 -- Create_Restricted_Task_Sequential. See comment of the former in the
131 -- specification of this package.
133 procedure Activate_Tasks
(Chain
: Task_Id
);
134 -- Activate the list of tasks started by Chain
137 -- This procedure performs the initialization of the GNARL.
138 -- It consists of initializing the environment task, global locks, and
139 -- installing tasking versions of certain operations used by the compiler.
140 -- Init_RTS is called during elaboration.
142 -----------------------
143 -- Get_Current_Excep --
144 -----------------------
146 function Get_Current_Excep
return SSL
.EOA
is
148 return STPO
.Self
.Common
.Compiler_Data
.Current_Excep
'Access;
149 end Get_Current_Excep
;
155 procedure Task_Lock
is
156 Self_ID
: constant Task_Id
:= STPO
.Self
;
159 Self_ID
.Common
.Global_Task_Lock_Nesting
:=
160 Self_ID
.Common
.Global_Task_Lock_Nesting
+ 1;
162 if Self_ID
.Common
.Global_Task_Lock_Nesting
= 1 then
163 STPO
.Write_Lock
(Global_Task_Lock
'Access, Global_Lock
=> True);
171 procedure Task_Unlock
is
172 Self_ID
: constant Task_Id
:= STPO
.Self
;
175 pragma Assert
(Self_ID
.Common
.Global_Task_Lock_Nesting
> 0);
176 Self_ID
.Common
.Global_Task_Lock_Nesting
:=
177 Self_ID
.Common
.Global_Task_Lock_Nesting
- 1;
179 if Self_ID
.Common
.Global_Task_Lock_Nesting
= 0 then
180 STPO
.Unlock
(Global_Task_Lock
'Access, Global_Lock
=> True);
188 -- The task wrapper is a procedure that is called first for each task
189 -- task body, and which in turn calls the compiler-generated task body
190 -- procedure. The wrapper's main job is to do initialization for the task.
192 -- The variable ID in the task wrapper is used to implement the Self
193 -- function on targets where there is a fast way to find the stack base
194 -- of the current thread, since it should be at a fixed offset from the
197 procedure Task_Wrapper
(Self_ID
: Task_Id
) is
198 ID
: Task_Id
:= Self_ID
;
199 pragma Volatile
(ID
);
200 pragma Warnings
(Off
, ID
);
201 -- Variable used on some targets to implement a fast self. We turn off
202 -- warnings because a stand alone volatile constant has to be imported,
203 -- so we don't want warnings about ID not being referenced, and volatile
206 -- DO NOT delete ID. As noted, it is needed on some targets.
208 use type SSE
.Storage_Offset
;
210 Secondary_Stack
: aliased SSE
.Storage_Array
211 (1 .. Self_ID
.Common
.Compiler_Data
.Pri_Stack_Info
.Size
*
212 SSE
.Storage_Offset
(Parameters
.Sec_Stack_Percentage
) / 100);
213 for Secondary_Stack
'Alignment use Standard
'Maximum_Alignment;
215 pragma Warnings
(Off
);
216 Secondary_Stack_Address
: System
.Address
:= Secondary_Stack
'Address;
217 pragma Warnings
(On
);
218 -- Address of secondary stack. In the fixed secondary stack case, this
219 -- value is not modified, causing a warning, hence the bracketing with
220 -- Warnings (Off/On).
222 Cause
: Cause_Of_Termination
:= Normal
;
223 -- Indicates the reason why this task terminates. Normal corresponds to
224 -- a task terminating due to completing the last statement of its body.
225 -- If the task terminates because of an exception raised by the
226 -- execution of its task body, then Cause is set to Unhandled_Exception.
227 -- Aborts are not allowed in the restricted profile to which this file
230 EO
: Exception_Occurrence
;
231 -- If the task terminates because of an exception raised by the
232 -- execution of its task body, then EO will contain the associated
233 -- exception occurrence. Otherwise, it will contain Null_Occurrence.
236 if not Parameters
.Sec_Stack_Dynamic
then
237 Self_ID
.Common
.Compiler_Data
.Sec_Stack_Addr
:=
238 Secondary_Stack
'Address;
239 SST
.SS_Init
(Secondary_Stack_Address
, Integer (Secondary_Stack
'Last));
242 -- Initialize low-level TCB components, that
243 -- cannot be initialized by the creator.
245 Enter_Task
(Self_ID
);
247 -- Call the task body procedure
250 -- We are separating the following portion of the code in order to
251 -- place the exception handlers in a different block. In this way we
252 -- do not call Set_Jmpbuf_Address (which needs Self) before we set
253 -- Self in Enter_Task.
255 -- Note that in the case of Ravenscar HI-E where there are no
256 -- exception handlers, the exception handler is suppressed.
258 -- Call the task body procedure
260 Self_ID
.Common
.Task_Entry_Point
(Self_ID
.Common
.Task_Arg
);
262 -- Normal task termination
265 Save_Occurrence
(EO
, Ada
.Exceptions
.Null_Occurrence
);
270 -- Task terminating because of an unhandled exception
272 Cause
:= Unhandled_Exception
;
273 Save_Occurrence
(EO
, E
);
276 -- Look for a fall-back handler
278 -- This package is part of the restricted run time which supports
279 -- neither task hierarchies (No_Task_Hierarchy) nor specific task
280 -- termination handlers (No_Specific_Termination_Handlers).
282 -- As specified in ARM C.7.3 par. 9/2, "the fall-back handler applies
283 -- only to the dependent tasks of the task". Hence, if the terminating
284 -- tasks (Self_ID) had a fall-back handler, it would not apply to
285 -- itself. This code is always executed by a task whose master is the
286 -- environment task (the task termination code for the environment task
287 -- is executed by SSL.Task_Termination_Handler), so the fall-back
288 -- handler to execute for this task can only be defined by its parent
289 -- (there is no grandparent).
292 TH
: Termination_Handler
:= null;
299 Write_Lock
(Self_ID
.Common
.Parent
);
301 TH
:= Self_ID
.Common
.Parent
.Common
.Fall_Back_Handler
;
303 Unlock
(Self_ID
.Common
.Parent
);
309 -- Execute the task termination handler if we found it
312 TH
.all (Cause
, Self_ID
, EO
);
316 Terminate_Task
(Self_ID
);
319 -----------------------
320 -- Restricted GNARLI --
321 -----------------------
323 -----------------------------------
324 -- Activate_All_Tasks_Sequential --
325 -----------------------------------
327 procedure Activate_All_Tasks_Sequential
is
329 pragma Assert
(Partition_Elaboration_Policy
= 'S');
331 Activate_Tasks
(Tasks_Activation_Chain
);
332 Tasks_Activation_Chain
:= Null_Task
;
333 end Activate_All_Tasks_Sequential
;
335 -------------------------------
336 -- Activate_Restricted_Tasks --
337 -------------------------------
339 procedure Activate_Restricted_Tasks
340 (Chain_Access
: Activation_Chain_Access
) is
342 if Partition_Elaboration_Policy
= 'S' then
344 -- In sequential elaboration policy, the chain must be empty. This
345 -- procedure can be called if the unit has been compiled without
346 -- partition elaboration policy, but the partition has a sequential
347 -- elaboration policy.
349 pragma Assert
(Chain_Access
.T_ID
= Null_Task
);
352 Activate_Tasks
(Chain_Access
.T_ID
);
353 Chain_Access
.T_ID
:= Null_Task
;
355 end Activate_Restricted_Tasks
;
361 -- Note that locks of activator and activated task are both locked here.
362 -- This is necessary because C.State and Self.Wait_Count have to be
363 -- synchronized. This is safe from deadlock because the activator is always
364 -- created before the activated task. That satisfies our
365 -- in-order-of-creation ATCB locking policy.
367 procedure Activate_Tasks
(Chain
: Task_Id
) is
368 Self_ID
: constant Task_Id
:= STPO
.Self
;
370 Activate_Prio
: System
.Any_Priority
;
374 pragma Assert
(Self_ID
= Environment_Task
);
375 pragma Assert
(Self_ID
.Common
.Wait_Count
= 0);
381 -- Lock self, to prevent activated tasks from racing ahead before we
382 -- finish activating the chain.
384 Write_Lock
(Self_ID
);
386 -- Activate all the tasks in the chain. Creation of the thread of
387 -- control was deferred until activation. So create it now.
391 if C
.Common
.State
/= Terminated
then
392 pragma Assert
(C
.Common
.State
= Unactivated
);
397 (if C
.Common
.Base_Priority
< Get_Priority
(Self_ID
)
398 then Get_Priority
(Self_ID
)
399 else C
.Common
.Base_Priority
);
402 (C
, Task_Wrapper
'Address,
404 (C
.Common
.Compiler_Data
.Pri_Stack_Info
.Size
),
405 Activate_Prio
, Success
);
407 Self_ID
.Common
.Wait_Count
:= Self_ID
.Common
.Wait_Count
+ 1;
410 C
.Common
.State
:= Runnable
;
418 C
:= C
.Common
.Activation_Link
;
421 Self_ID
.Common
.State
:= Activator_Sleep
;
423 -- Wait for the activated tasks to complete activation. It is unsafe to
424 -- abort any of these tasks until the count goes to zero.
427 exit when Self_ID
.Common
.Wait_Count
= 0;
428 Sleep
(Self_ID
, Activator_Sleep
);
431 Self_ID
.Common
.State
:= Runnable
;
439 ------------------------------------
440 -- Complete_Restricted_Activation --
441 ------------------------------------
443 -- As in several other places, the locks of the activator and activated
444 -- task are both locked here. This follows our deadlock prevention lock
445 -- ordering policy, since the activated task must be created after the
448 procedure Complete_Restricted_Activation
is
449 Self_ID
: constant Task_Id
:= STPO
.Self
;
450 Activator
: constant Task_Id
:= Self_ID
.Common
.Activator
;
457 Write_Lock
(Activator
);
458 Write_Lock
(Self_ID
);
460 -- Remove dangling reference to Activator, since a task may outlive its
463 Self_ID
.Common
.Activator
:= null;
465 -- Wake up the activator, if it is waiting for a chain of tasks to
466 -- activate, and we are the last in the chain to complete activation
468 if Activator
.Common
.State
= Activator_Sleep
then
469 Activator
.Common
.Wait_Count
:= Activator
.Common
.Wait_Count
- 1;
471 if Activator
.Common
.Wait_Count
= 0 then
472 Wakeup
(Activator
, Activator_Sleep
);
483 -- After the activation, active priority should be the same as base
484 -- priority. We must unlock the Activator first, though, since it should
485 -- not wait if we have lower priority.
487 if Get_Priority
(Self_ID
) /= Self_ID
.Common
.Base_Priority
then
488 Set_Priority
(Self_ID
, Self_ID
.Common
.Base_Priority
);
490 end Complete_Restricted_Activation
;
492 ------------------------------
493 -- Complete_Restricted_Task --
494 ------------------------------
496 procedure Complete_Restricted_Task
is
498 STPO
.Self
.Common
.State
:= Terminated
;
499 end Complete_Restricted_Task
;
501 ----------------------------
502 -- Create_Restricted_Task --
503 ----------------------------
505 procedure Create_Restricted_Task
507 Stack_Address
: System
.Address
;
508 Size
: System
.Parameters
.Size_Type
;
509 Task_Info
: System
.Task_Info
.Task_Info_Type
;
511 State
: Task_Procedure_Access
;
512 Discriminants
: System
.Address
;
513 Elaborated
: Access_Boolean
;
515 Created_Task
: Task_Id
)
517 Self_ID
: constant Task_Id
:= STPO
.Self
;
518 Base_Priority
: System
.Any_Priority
;
519 Base_CPU
: System
.Multiprocessors
.CPU_Range
;
524 -- Stack is not preallocated on this target, so that Stack_Address must
527 pragma Assert
(Stack_Address
= Null_Address
);
530 (if Priority
= Unspecified_Priority
531 then Self_ID
.Common
.Base_Priority
532 else System
.Any_Priority
(Priority
));
534 -- Legal values of CPU are the special Unspecified_CPU value which is
535 -- inserted by the compiler for tasks without CPU aspect, and those in
536 -- the range of CPU_Range but no greater than Number_Of_CPUs. Otherwise
537 -- the task is defined to have failed, and it becomes a completed task
540 if CPU
/= Unspecified_CPU
541 and then (CPU
< Integer (System
.Multiprocessors
.CPU_Range
'First)
542 or else CPU
> Integer (System
.Multiprocessors
.Number_Of_CPUs
))
544 raise Tasking_Error
with "CPU not in range";
546 -- Normal CPU affinity
548 -- When the application code says nothing about the task affinity
549 -- (task without CPU aspect) then the compiler inserts the
550 -- Unspecified_CPU value which indicates to the run-time library that
551 -- the task will activate and execute on the same processor as its
552 -- activating task if the activating task is assigned a processor
556 (if CPU
= Unspecified_CPU
557 then Self_ID
.Common
.Base_CPU
558 else System
.Multiprocessors
.CPU_Range
(CPU
));
565 Write_Lock
(Self_ID
);
567 -- With no task hierarchy, the parent of all non-Environment tasks that
568 -- are created must be the Environment task. Dispatching domains are
569 -- not allowed in Ravenscar, so the dispatching domain parameter will
573 (Self_ID
, State
, Discriminants
, Self_ID
, Elaborated
, Base_Priority
,
574 Base_CPU
, null, Task_Info
, Size
, Created_Task
, Success
);
576 -- If we do our job right then there should never be any failures, which
577 -- was probably said about the Titanic; so just to be safe, let's retain
590 Created_Task
.Entry_Calls
(1).Self
:= Created_Task
;
593 Integer'Min (Created_Task
.Common
.Task_Image
'Length, Task_Image
'Length);
594 Created_Task
.Common
.Task_Image_Len
:= Len
;
595 Created_Task
.Common
.Task_Image
(1 .. Len
) :=
596 Task_Image
(Task_Image
'First .. Task_Image
'First + Len
- 1);
604 -- Create TSD as early as possible in the creation of a task, since it
605 -- may be used by the operation of Ada code within the task.
607 SSL
.Create_TSD
(Created_Task
.Common
.Compiler_Data
);
608 end Create_Restricted_Task
;
610 procedure Create_Restricted_Task
612 Stack_Address
: System
.Address
;
613 Size
: System
.Parameters
.Size_Type
;
614 Task_Info
: System
.Task_Info
.Task_Info_Type
;
616 State
: Task_Procedure_Access
;
617 Discriminants
: System
.Address
;
618 Elaborated
: Access_Boolean
;
619 Chain
: in out Activation_Chain
;
621 Created_Task
: Task_Id
)
624 if Partition_Elaboration_Policy
= 'S' then
626 -- A unit may have been compiled without partition elaboration
627 -- policy, and in this case the compiler will emit calls for the
628 -- default policy (concurrent). But if the partition policy is
629 -- sequential, activation must be deferred.
631 Create_Restricted_Task_Sequential
632 (Priority
, Stack_Address
, Size
, Task_Info
, CPU
, State
,
633 Discriminants
, Elaborated
, Task_Image
, Created_Task
);
636 Create_Restricted_Task
637 (Priority
, Stack_Address
, Size
, Task_Info
, CPU
, State
,
638 Discriminants
, Elaborated
, Task_Image
, Created_Task
);
640 -- Append this task to the activation chain
642 Created_Task
.Common
.Activation_Link
:= Chain
.T_ID
;
643 Chain
.T_ID
:= Created_Task
;
645 end Create_Restricted_Task
;
647 ---------------------------------------
648 -- Create_Restricted_Task_Sequential --
649 ---------------------------------------
651 procedure Create_Restricted_Task_Sequential
653 Stack_Address
: System
.Address
;
654 Size
: System
.Parameters
.Size_Type
;
655 Task_Info
: System
.Task_Info
.Task_Info_Type
;
657 State
: Task_Procedure_Access
;
658 Discriminants
: System
.Address
;
659 Elaborated
: Access_Boolean
;
661 Created_Task
: Task_Id
) is
663 Create_Restricted_Task
(Priority
, Stack_Address
, Size
, Task_Info
,
664 CPU
, State
, Discriminants
, Elaborated
,
665 Task_Image
, Created_Task
);
667 -- Append this task to the activation chain
669 Created_Task
.Common
.Activation_Link
:= Tasks_Activation_Chain
;
670 Tasks_Activation_Chain
:= Created_Task
;
671 end Create_Restricted_Task_Sequential
;
673 ---------------------------
674 -- Finalize_Global_Tasks --
675 ---------------------------
677 -- This is needed to support the compiler interface; it will only be called
678 -- by the Environment task. Instead, it will cause the Environment to block
679 -- forever, since none of the dependent tasks are expected to terminate
681 procedure Finalize_Global_Tasks
is
682 Self_ID
: constant Task_Id
:= STPO
.Self
;
685 pragma Assert
(Self_ID
= STPO
.Environment_Task
);
691 -- Handle normal task termination by the environment task, but only for
692 -- the normal task termination. In the case of Abnormal and
693 -- Unhandled_Exception they must have been handled before, and the task
694 -- termination soft link must have been changed so the task termination
695 -- routine is not executed twice.
697 -- Note that in the "normal" implementation in s-tassta.adb the task
698 -- termination procedure for the environment task should be executed
699 -- after termination of library-level tasks. However, this
700 -- implementation is to be used when the Ravenscar restrictions are in
701 -- effect, and AI-394 says that if there is a fall-back handler set for
702 -- the partition it should be called when the first task (including the
703 -- environment task) attempts to terminate.
705 SSL
.Task_Termination_Handler
.all (Ada
.Exceptions
.Null_Occurrence
);
707 Write_Lock
(Self_ID
);
708 Sleep
(Self_ID
, Master_Completion_Sleep
);
715 -- Should never return from Master Completion Sleep
718 end Finalize_Global_Tasks
;
720 ---------------------------
721 -- Restricted_Terminated --
722 ---------------------------
724 function Restricted_Terminated
(T
: Task_Id
) return Boolean is
726 return T
.Common
.State
= Terminated
;
727 end Restricted_Terminated
;
733 procedure Terminate_Task
(Self_ID
: Task_Id
) is
735 Self_ID
.Common
.State
:= Terminated
;
742 procedure Init_RTS
is
746 -- Initialize lock used to implement mutual exclusion between all tasks
748 STPO
.Initialize_Lock
(Global_Task_Lock
'Access, STPO
.Global_Task_Level
);
750 -- Notify that the tasking run time has been elaborated so that
751 -- the tasking version of the soft links can be used.
753 SSL
.Lock_Task
:= Task_Lock
'Access;
754 SSL
.Unlock_Task
:= Task_Unlock
'Access;
755 SSL
.Adafinal
:= Finalize_Global_Tasks
'Access;
756 SSL
.Get_Current_Excep
:= Get_Current_Excep
'Access;
758 -- Initialize the tasking soft links (if not done yet) that are common
759 -- to the full and the restricted run times.
761 SSL
.Tasking
.Init_Tasking_Soft_Links
;
766 end System
.Tasking
.Restricted
.Stages
;