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-2018, 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
;
51 with System
.Soft_Links
;
52 -- Used for the non-tasking routines (*_NT) that refer to global data. They
53 -- are needed here before the tasking run time has been elaborated. used for
54 -- Create_TSD This package also provides initialization routines for task
55 -- specific data. The GNARL must call these to be sure that all non-tasking
56 -- Ada constructs will work.
58 package body System
.Tasking
.Restricted
.Stages
is
60 package STPO
renames System
.Task_Primitives
.Operations
;
61 package SSL
renames System
.Soft_Links
;
66 use Task_Primitives
.Operations
;
68 Tasks_Activation_Chain
: Task_Id
;
69 -- Chain of all the tasks to activate
71 Global_Task_Lock
: aliased System
.Task_Primitives
.RTS_Lock
;
72 -- This is a global lock; it is used to execute in mutual exclusion
73 -- from all other tasks. It is only used by Task_Lock and Task_Unlock.
75 -----------------------------------------------------------------
76 -- Tasking versions of services needed by non-tasking programs --
77 -----------------------------------------------------------------
79 function Get_Current_Excep
return SSL
.EOA
;
80 -- Task-safe version of SSL.Get_Current_Excep
83 -- Locks out other tasks. Preceding a section of code by Task_Lock and
84 -- following it by Task_Unlock creates a critical region. This is used
85 -- for ensuring that a region of non-tasking code (such as code used to
86 -- allocate memory) is tasking safe. Note that it is valid for calls to
87 -- Task_Lock/Task_Unlock to be nested, and this must work properly, i.e.
88 -- only the corresponding outer level Task_Unlock will actually unlock.
90 procedure Task_Unlock
;
91 -- Releases lock previously set by call to Task_Lock. In the nested case,
92 -- all nested locks must be released before other tasks competing for the
93 -- tasking lock are released.
95 -----------------------
96 -- Local Subprograms --
97 -----------------------
99 procedure Task_Wrapper
(Self_ID
: Task_Id
);
100 -- This is the procedure that is called by the GNULL from the
101 -- new context when a task is created. It waits for activation
102 -- and then calls the task body procedure. When the task body
103 -- procedure completes, it terminates the task.
105 procedure Terminate_Task
(Self_ID
: Task_Id
);
106 -- Terminate the calling task.
107 -- This should only be called by the Task_Wrapper procedure.
109 procedure Create_Restricted_Task
111 Stack_Address
: System
.Address
;
112 Stack_Size
: System
.Parameters
.Size_Type
;
113 Sec_Stack_Address
: System
.Secondary_Stack
.SS_Stack_Ptr
;
114 Sec_Stack_Size
: System
.Parameters
.Size_Type
;
115 Task_Info
: System
.Task_Info
.Task_Info_Type
;
117 State
: Task_Procedure_Access
;
118 Discriminants
: System
.Address
;
119 Elaborated
: Access_Boolean
;
121 Created_Task
: Task_Id
);
122 -- Code shared between Create_Restricted_Task (the concurrent version) and
123 -- Create_Restricted_Task_Sequential. See comment of the former in the
124 -- specification of this package.
126 procedure Activate_Tasks
(Chain
: Task_Id
);
127 -- Activate the list of tasks started by Chain
130 -- This procedure performs the initialization of the GNARL.
131 -- It consists of initializing the environment task, global locks, and
132 -- installing tasking versions of certain operations used by the compiler.
133 -- Init_RTS is called during elaboration.
135 -----------------------
136 -- Get_Current_Excep --
137 -----------------------
139 function Get_Current_Excep
return SSL
.EOA
is
141 return STPO
.Self
.Common
.Compiler_Data
.Current_Excep
'Access;
142 end Get_Current_Excep
;
148 procedure Task_Lock
is
149 Self_ID
: constant Task_Id
:= STPO
.Self
;
152 Self_ID
.Common
.Global_Task_Lock_Nesting
:=
153 Self_ID
.Common
.Global_Task_Lock_Nesting
+ 1;
155 if Self_ID
.Common
.Global_Task_Lock_Nesting
= 1 then
156 STPO
.Write_Lock
(Global_Task_Lock
'Access, Global_Lock
=> True);
164 procedure Task_Unlock
is
165 Self_ID
: constant Task_Id
:= STPO
.Self
;
168 pragma Assert
(Self_ID
.Common
.Global_Task_Lock_Nesting
> 0);
169 Self_ID
.Common
.Global_Task_Lock_Nesting
:=
170 Self_ID
.Common
.Global_Task_Lock_Nesting
- 1;
172 if Self_ID
.Common
.Global_Task_Lock_Nesting
= 0 then
173 STPO
.Unlock
(Global_Task_Lock
'Access, Global_Lock
=> True);
181 -- The task wrapper is a procedure that is called first for each task
182 -- task body, and which in turn calls the compiler-generated task body
183 -- procedure. The wrapper's main job is to do initialization for the task.
185 -- The variable ID in the task wrapper is used to implement the Self
186 -- function on targets where there is a fast way to find the stack base
187 -- of the current thread, since it should be at a fixed offset from the
190 procedure Task_Wrapper
(Self_ID
: Task_Id
) is
191 ID
: Task_Id
:= Self_ID
;
192 pragma Volatile
(ID
);
193 pragma Warnings
(Off
, ID
);
194 -- Variable used on some targets to implement a fast self. We turn off
195 -- warnings because a stand alone volatile constant has to be imported,
196 -- so we don't want warnings about ID not being referenced, and volatile
199 -- DO NOT delete ID. As noted, it is needed on some targets.
201 Cause
: Cause_Of_Termination
:= Normal
;
202 -- Indicates the reason why this task terminates. Normal corresponds to
203 -- a task terminating due to completing the last statement of its body.
204 -- If the task terminates because of an exception raised by the
205 -- execution of its task body, then Cause is set to Unhandled_Exception.
206 -- Aborts are not allowed in the restricted profile to which this file
209 EO
: Exception_Occurrence
;
210 -- If the task terminates because of an exception raised by the
211 -- execution of its task body, then EO will contain the associated
212 -- exception occurrence. Otherwise, it will contain Null_Occurrence.
215 -- Initialize low-level TCB components, that cannot be initialized by
218 Enter_Task
(Self_ID
);
220 -- Call the task body procedure
223 -- We are separating the following portion of the code in order to
224 -- place the exception handlers in a different block. In this way we
225 -- do not call Set_Jmpbuf_Address (which needs Self) before we set
226 -- Self in Enter_Task.
228 -- Note that in the case of Ravenscar HI-E where there are no
229 -- exception handlers, the exception handler is suppressed.
231 -- Call the task body procedure
233 Self_ID
.Common
.Task_Entry_Point
(Self_ID
.Common
.Task_Arg
);
235 -- Normal task termination
238 Save_Occurrence
(EO
, Ada
.Exceptions
.Null_Occurrence
);
243 -- Task terminating because of an unhandled exception
245 Cause
:= Unhandled_Exception
;
246 Save_Occurrence
(EO
, E
);
249 -- Look for a fall-back handler
251 -- This package is part of the restricted run time which supports
252 -- neither task hierarchies (No_Task_Hierarchy) nor specific task
253 -- termination handlers (No_Specific_Termination_Handlers).
255 -- As specified in ARM C.7.3 par. 9/2, "the fall-back handler applies
256 -- only to the dependent tasks of the task". Hence, if the terminating
257 -- tasks (Self_ID) had a fall-back handler, it would not apply to
258 -- itself. This code is always executed by a task whose master is the
259 -- environment task (the task termination code for the environment task
260 -- is executed by SSL.Task_Termination_Handler), so the fall-back
261 -- handler to execute for this task can only be defined by its parent
262 -- (there is no grandparent).
265 TH
: Termination_Handler
:= null;
272 Write_Lock
(Self_ID
.Common
.Parent
);
274 TH
:= Self_ID
.Common
.Parent
.Common
.Fall_Back_Handler
;
276 Unlock
(Self_ID
.Common
.Parent
);
282 -- Execute the task termination handler if we found it
285 TH
.all (Cause
, Self_ID
, EO
);
289 Terminate_Task
(Self_ID
);
292 -----------------------
293 -- Restricted GNARLI --
294 -----------------------
296 -----------------------------------
297 -- Activate_All_Tasks_Sequential --
298 -----------------------------------
300 procedure Activate_All_Tasks_Sequential
is
302 pragma Assert
(Partition_Elaboration_Policy
= 'S');
304 Activate_Tasks
(Tasks_Activation_Chain
);
305 Tasks_Activation_Chain
:= Null_Task
;
306 end Activate_All_Tasks_Sequential
;
308 -------------------------------
309 -- Activate_Restricted_Tasks --
310 -------------------------------
312 procedure Activate_Restricted_Tasks
313 (Chain_Access
: Activation_Chain_Access
) is
315 if Partition_Elaboration_Policy
= 'S' then
317 -- In sequential elaboration policy, the chain must be empty. This
318 -- procedure can be called if the unit has been compiled without
319 -- partition elaboration policy, but the partition has a sequential
320 -- elaboration policy.
322 pragma Assert
(Chain_Access
.T_ID
= Null_Task
);
325 Activate_Tasks
(Chain_Access
.T_ID
);
326 Chain_Access
.T_ID
:= Null_Task
;
328 end Activate_Restricted_Tasks
;
334 -- Note that locks of activator and activated task are both locked here.
335 -- This is necessary because C.State and Self.Wait_Count have to be
336 -- synchronized. This is safe from deadlock because the activator is always
337 -- created before the activated task. That satisfies our
338 -- in-order-of-creation ATCB locking policy.
340 procedure Activate_Tasks
(Chain
: Task_Id
) is
341 Self_ID
: constant Task_Id
:= STPO
.Self
;
343 Activate_Prio
: System
.Any_Priority
;
347 pragma Assert
(Self_ID
= Environment_Task
);
348 pragma Assert
(Self_ID
.Common
.Wait_Count
= 0);
354 -- Lock self, to prevent activated tasks from racing ahead before we
355 -- finish activating the chain.
357 Write_Lock
(Self_ID
);
359 -- Activate all the tasks in the chain. Creation of the thread of
360 -- control was deferred until activation. So create it now.
364 if C
.Common
.State
/= Terminated
then
365 pragma Assert
(C
.Common
.State
= Unactivated
);
370 (if C
.Common
.Base_Priority
< Get_Priority
(Self_ID
)
371 then Get_Priority
(Self_ID
)
372 else C
.Common
.Base_Priority
);
375 (C
, Task_Wrapper
'Address,
377 (C
.Common
.Compiler_Data
.Pri_Stack_Info
.Size
),
378 Activate_Prio
, Success
);
380 Self_ID
.Common
.Wait_Count
:= Self_ID
.Common
.Wait_Count
+ 1;
383 C
.Common
.State
:= Runnable
;
391 C
:= C
.Common
.Activation_Link
;
394 Self_ID
.Common
.State
:= Activator_Sleep
;
396 -- Wait for the activated tasks to complete activation. It is unsafe to
397 -- abort any of these tasks until the count goes to zero.
400 exit when Self_ID
.Common
.Wait_Count
= 0;
401 Sleep
(Self_ID
, Activator_Sleep
);
404 Self_ID
.Common
.State
:= Runnable
;
412 ------------------------------------
413 -- Complete_Restricted_Activation --
414 ------------------------------------
416 -- As in several other places, the locks of the activator and activated
417 -- task are both locked here. This follows our deadlock prevention lock
418 -- ordering policy, since the activated task must be created after the
421 procedure Complete_Restricted_Activation
is
422 Self_ID
: constant Task_Id
:= STPO
.Self
;
423 Activator
: constant Task_Id
:= Self_ID
.Common
.Activator
;
430 Write_Lock
(Activator
);
431 Write_Lock
(Self_ID
);
433 -- Remove dangling reference to Activator, since a task may outlive its
436 Self_ID
.Common
.Activator
:= null;
438 -- Wake up the activator, if it is waiting for a chain of tasks to
439 -- activate, and we are the last in the chain to complete activation
441 if Activator
.Common
.State
= Activator_Sleep
then
442 Activator
.Common
.Wait_Count
:= Activator
.Common
.Wait_Count
- 1;
444 if Activator
.Common
.Wait_Count
= 0 then
445 Wakeup
(Activator
, Activator_Sleep
);
456 -- After the activation, active priority should be the same as base
457 -- priority. We must unlock the Activator first, though, since it should
458 -- not wait if we have lower priority.
460 if Get_Priority
(Self_ID
) /= Self_ID
.Common
.Base_Priority
then
461 Set_Priority
(Self_ID
, Self_ID
.Common
.Base_Priority
);
463 end Complete_Restricted_Activation
;
465 ------------------------------
466 -- Complete_Restricted_Task --
467 ------------------------------
469 procedure Complete_Restricted_Task
is
471 STPO
.Self
.Common
.State
:= Terminated
;
472 end Complete_Restricted_Task
;
474 ----------------------------
475 -- Create_Restricted_Task --
476 ----------------------------
478 procedure Create_Restricted_Task
480 Stack_Address
: System
.Address
;
481 Stack_Size
: System
.Parameters
.Size_Type
;
482 Sec_Stack_Address
: System
.Secondary_Stack
.SS_Stack_Ptr
;
483 Sec_Stack_Size
: System
.Parameters
.Size_Type
;
484 Task_Info
: System
.Task_Info
.Task_Info_Type
;
486 State
: Task_Procedure_Access
;
487 Discriminants
: System
.Address
;
488 Elaborated
: Access_Boolean
;
490 Created_Task
: Task_Id
)
492 Self_ID
: constant Task_Id
:= STPO
.Self
;
493 Base_Priority
: System
.Any_Priority
;
494 Base_CPU
: System
.Multiprocessors
.CPU_Range
;
499 -- Stack is not preallocated on this target, so that Stack_Address must
502 pragma Assert
(Stack_Address
= Null_Address
);
505 (if Priority
= Unspecified_Priority
506 then Self_ID
.Common
.Base_Priority
507 else System
.Any_Priority
(Priority
));
509 -- Legal values of CPU are the special Unspecified_CPU value which is
510 -- inserted by the compiler for tasks without CPU aspect, and those in
511 -- the range of CPU_Range but no greater than Number_Of_CPUs. Otherwise
512 -- the task is defined to have failed, and it becomes a completed task
515 if CPU
/= Unspecified_CPU
516 and then (CPU
< Integer (System
.Multiprocessors
.CPU_Range
'First)
517 or else CPU
> Integer (System
.Multiprocessors
.Number_Of_CPUs
))
519 raise Tasking_Error
with "CPU not in range";
521 -- Normal CPU affinity
523 -- When the application code says nothing about the task affinity
524 -- (task without CPU aspect) then the compiler inserts the
525 -- Unspecified_CPU value which indicates to the run-time library that
526 -- the task will activate and execute on the same processor as its
527 -- activating task if the activating task is assigned a processor
531 (if CPU
= Unspecified_CPU
532 then Self_ID
.Common
.Base_CPU
533 else System
.Multiprocessors
.CPU_Range
(CPU
));
540 Write_Lock
(Self_ID
);
542 -- With no task hierarchy, the parent of all non-Environment tasks that
543 -- are created must be the Environment task. Dispatching domains are
544 -- not allowed in Ravenscar, so the dispatching domain parameter will
548 (Self_ID
, State
, Discriminants
, Self_ID
, Elaborated
, Base_Priority
,
549 Base_CPU
, null, Task_Info
, Stack_Size
, Created_Task
, Success
);
551 -- If we do our job right then there should never be any failures, which
552 -- was probably said about the Titanic; so just to be safe, let's retain
565 Created_Task
.Entry_Calls
(1).Self
:= Created_Task
;
568 Integer'Min (Created_Task
.Common
.Task_Image
'Length, Task_Image
'Length);
569 Created_Task
.Common
.Task_Image_Len
:= Len
;
570 Created_Task
.Common
.Task_Image
(1 .. Len
) :=
571 Task_Image
(Task_Image
'First .. Task_Image
'First + Len
- 1);
579 -- Create TSD as early as possible in the creation of a task, since
580 -- it may be used by the operation of Ada code within the task. If the
581 -- compiler has not allocated a secondary stack, a stack will be
582 -- allocated fromt the binder generated pool.
585 (Created_Task
.Common
.Compiler_Data
,
588 end Create_Restricted_Task
;
590 procedure Create_Restricted_Task
592 Stack_Address
: System
.Address
;
593 Stack_Size
: System
.Parameters
.Size_Type
;
594 Sec_Stack_Address
: System
.Secondary_Stack
.SS_Stack_Ptr
;
595 Sec_Stack_Size
: System
.Parameters
.Size_Type
;
596 Task_Info
: System
.Task_Info
.Task_Info_Type
;
598 State
: Task_Procedure_Access
;
599 Discriminants
: System
.Address
;
600 Elaborated
: Access_Boolean
;
601 Chain
: in out Activation_Chain
;
603 Created_Task
: Task_Id
)
606 if Partition_Elaboration_Policy
= 'S' then
608 -- A unit may have been compiled without partition elaboration
609 -- policy, and in this case the compiler will emit calls for the
610 -- default policy (concurrent). But if the partition policy is
611 -- sequential, activation must be deferred.
613 Create_Restricted_Task_Sequential
614 (Priority
, Stack_Address
, Stack_Size
, Sec_Stack_Address
,
615 Sec_Stack_Size
, Task_Info
, CPU
, State
, Discriminants
, Elaborated
,
616 Task_Image
, Created_Task
);
619 Create_Restricted_Task
620 (Priority
, Stack_Address
, Stack_Size
, Sec_Stack_Address
,
621 Sec_Stack_Size
, Task_Info
, CPU
, State
, Discriminants
, Elaborated
,
622 Task_Image
, Created_Task
);
624 -- Append this task to the activation chain
626 Created_Task
.Common
.Activation_Link
:= Chain
.T_ID
;
627 Chain
.T_ID
:= Created_Task
;
629 end Create_Restricted_Task
;
631 ---------------------------------------
632 -- Create_Restricted_Task_Sequential --
633 ---------------------------------------
635 procedure Create_Restricted_Task_Sequential
637 Stack_Address
: System
.Address
;
638 Stack_Size
: System
.Parameters
.Size_Type
;
639 Sec_Stack_Address
: System
.Secondary_Stack
.SS_Stack_Ptr
;
640 Sec_Stack_Size
: System
.Parameters
.Size_Type
;
641 Task_Info
: System
.Task_Info
.Task_Info_Type
;
643 State
: Task_Procedure_Access
;
644 Discriminants
: System
.Address
;
645 Elaborated
: Access_Boolean
;
647 Created_Task
: Task_Id
)
650 Create_Restricted_Task
651 (Priority
, Stack_Address
, Stack_Size
, Sec_Stack_Address
,
652 Sec_Stack_Size
, Task_Info
, CPU
, State
, Discriminants
, Elaborated
,
653 Task_Image
, Created_Task
);
655 -- Append this task to the activation chain
657 Created_Task
.Common
.Activation_Link
:= Tasks_Activation_Chain
;
658 Tasks_Activation_Chain
:= Created_Task
;
659 end Create_Restricted_Task_Sequential
;
661 ---------------------------
662 -- Finalize_Global_Tasks --
663 ---------------------------
665 -- This is needed to support the compiler interface; it will only be called
666 -- by the Environment task. Instead, it will cause the Environment to block
667 -- forever, since none of the dependent tasks are expected to terminate
669 procedure Finalize_Global_Tasks
is
670 Self_ID
: constant Task_Id
:= STPO
.Self
;
673 pragma Assert
(Self_ID
= STPO
.Environment_Task
);
679 -- Handle normal task termination by the environment task, but only for
680 -- the normal task termination. In the case of Abnormal and
681 -- Unhandled_Exception they must have been handled before, and the task
682 -- termination soft link must have been changed so the task termination
683 -- routine is not executed twice.
685 -- Note that in the "normal" implementation in s-tassta.adb the task
686 -- termination procedure for the environment task should be executed
687 -- after termination of library-level tasks. However, this
688 -- implementation is to be used when the Ravenscar restrictions are in
689 -- effect, and AI-394 says that if there is a fall-back handler set for
690 -- the partition it should be called when the first task (including the
691 -- environment task) attempts to terminate.
693 SSL
.Task_Termination_Handler
.all (Ada
.Exceptions
.Null_Occurrence
);
695 Write_Lock
(Self_ID
);
696 Sleep
(Self_ID
, Master_Completion_Sleep
);
703 -- Should never return from Master Completion Sleep
706 end Finalize_Global_Tasks
;
708 ---------------------------
709 -- Restricted_Terminated --
710 ---------------------------
712 function Restricted_Terminated
(T
: Task_Id
) return Boolean is
714 return T
.Common
.State
= Terminated
;
715 end Restricted_Terminated
;
721 procedure Terminate_Task
(Self_ID
: Task_Id
) is
723 Self_ID
.Common
.State
:= Terminated
;
730 procedure Init_RTS
is
734 -- Initialize lock used to implement mutual exclusion between all tasks
736 STPO
.Initialize_Lock
(Global_Task_Lock
'Access, STPO
.Global_Task_Level
);
738 -- Notify that the tasking run time has been elaborated so that
739 -- the tasking version of the soft links can be used.
741 SSL
.Lock_Task
:= Task_Lock
'Access;
742 SSL
.Unlock_Task
:= Task_Unlock
'Access;
743 SSL
.Adafinal
:= Finalize_Global_Tasks
'Access;
744 SSL
.Get_Current_Excep
:= Get_Current_Excep
'Access;
746 -- Initialize the tasking soft links (if not done yet) that are common
747 -- to the full and the restricted run times.
749 SSL
.Tasking
.Init_Tasking_Soft_Links
;
754 end System
.Tasking
.Restricted
.Stages
;