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-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 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.
48 with System
.Parameters
;
52 with System
.Task_Info
;
53 -- used for Task_Info_Type
55 with System
.Task_Primitives
.Operations
;
56 -- used for Enter_Task
62 with System
.Soft_Links
;
63 -- used for the non-tasking routines (*_NT) that refer to global data.
64 -- They are needed here before the tasking run time has been elaborated.
65 -- used for Create_TSD
66 -- This package also provides initialization routines for task specific data.
67 -- The GNARL must call these to be sure that all non-tasking
68 -- Ada constructs will work.
70 with System
.Soft_Links
.Tasking
;
71 -- Used for Init_Tasking_Soft_Links
73 with System
.Secondary_Stack
;
76 with System
.Storage_Elements
;
77 -- used for Storage_Array;
79 package body System
.Tasking
.Restricted
.Stages
is
81 package STPO
renames System
.Task_Primitives
.Operations
;
82 package SSL
renames System
.Soft_Links
;
83 package SSE
renames System
.Storage_Elements
;
84 package SST
renames System
.Secondary_Stack
;
87 use Task_Primitives
.Operations
;
90 Global_Task_Lock
: aliased System
.Task_Primitives
.RTS_Lock
;
91 -- This is a global lock; it is used to execute in mutual exclusion
92 -- from all other tasks. It is only used by Task_Lock and Task_Unlock.
94 -----------------------------------------------------------------
95 -- Tasking versions of services needed by non-tasking programs --
96 -----------------------------------------------------------------
99 -- Locks out other tasks. Preceding a section of code by Task_Lock and
100 -- following it by Task_Unlock creates a critical region. This is used
101 -- for ensuring that a region of non-tasking code (such as code used to
102 -- allocate memory) is tasking safe. Note that it is valid for calls to
103 -- Task_Lock/Task_Unlock to be nested, and this must work properly, i.e.
104 -- only the corresponding outer level Task_Unlock will actually unlock.
106 procedure Task_Unlock
;
107 -- Releases lock previously set by call to Task_Lock. In the nested case,
108 -- all nested locks must be released before other tasks competing for the
109 -- tasking lock are released.
111 -----------------------
112 -- Local Subprograms --
113 -----------------------
115 procedure Task_Wrapper
(Self_ID
: Task_Id
);
116 -- This is the procedure that is called by the GNULL from the
117 -- new context when a task is created. It waits for activation
118 -- and then calls the task body procedure. When the task body
119 -- procedure completes, it terminates the task.
121 procedure Terminate_Task
(Self_ID
: Task_Id
);
122 -- Terminate the calling task.
123 -- This should only be called by the Task_Wrapper procedure.
126 -- This procedure performs the initialization of the GNARL.
127 -- It consists of initializing the environment task, global locks, and
128 -- installing tasking versions of certain operations used by the compiler.
129 -- Init_RTS is called during elaboration.
135 procedure Task_Lock
is
137 STPO
.Write_Lock
(Global_Task_Lock
'Access, Global_Lock
=> True);
144 procedure Task_Unlock
is
146 STPO
.Unlock
(Global_Task_Lock
'Access, Global_Lock
=> True);
153 -- The task wrapper is a procedure that is called first for each task
154 -- task body, and which in turn calls the compiler-generated task body
155 -- procedure. The wrapper's main job is to do initialization for the task.
157 -- The variable ID in the task wrapper is used to implement the Self
158 -- function on targets where there is a fast way to find the stack base
159 -- of the current thread, since it should be at a fixed offset from the
162 procedure Task_Wrapper
(Self_ID
: Task_Id
) is
163 ID
: Task_Id
:= Self_ID
;
164 pragma Volatile
(ID
);
166 pragma Warnings
(Off
, ID
);
167 -- Turn off warnings (stand alone volatile constant has to be
168 -- imported, so we cannot just make ID constant).
170 -- Do not delete this variable.
171 -- In some targets, we need this variable to implement a fast Self.
173 use type System
.Parameters
.Size_Type
;
174 use type SSE
.Storage_Offset
;
176 Secondary_Stack
: aliased SSE
.Storage_Array
177 (1 .. Self_ID
.Common
.Compiler_Data
.Pri_Stack_Info
.Size
*
178 SSE
.Storage_Offset
(Parameters
.Sec_Stack_Ratio
) / 100);
179 Secondary_Stack_Address
: System
.Address
:= Secondary_Stack
'Address;
182 if not Parameters
.Sec_Stack_Dynamic
then
183 Self_ID
.Common
.Compiler_Data
.Sec_Stack_Addr
:=
184 Secondary_Stack
'Address;
185 SST
.SS_Init
(Secondary_Stack_Address
, Integer (Secondary_Stack
'Last));
188 -- Initialize low-level TCB components, that
189 -- cannot be initialized by the creator.
191 Enter_Task
(Self_ID
);
193 -- Call the task body procedure.
196 -- We are separating the following portion of the code in order to
197 -- place the exception handlers in a different block.
198 -- In this way we do not call Set_Jmpbuf_Address (which needs
199 -- Self) before we set Self in Enter_Task.
200 -- Note that in the case of Ravenscar HI-E where there are no
201 -- exception handlers, the exception handler is suppressed.
203 -- Call the task body procedure.
205 Self_ID
.Common
.Task_Entry_Point
(Self_ID
.Common
.Task_Arg
);
206 Terminate_Task
(Self_ID
);
210 Terminate_Task
(Self_ID
);
214 -----------------------
215 -- Restricted GNARLI --
216 -----------------------
218 -------------------------------
219 -- Activate_Restricted_Tasks --
220 -------------------------------
222 -- Note that locks of activator and activated task are both locked
223 -- here. This is necessary because C.State and Self.Wait_Count
224 -- have to be synchronized. This is safe from deadlock because
225 -- the activator is always created before the activated task.
226 -- That satisfies our in-order-of-creation ATCB locking policy.
228 procedure Activate_Restricted_Tasks
229 (Chain_Access
: Activation_Chain_Access
)
231 Self_ID
: constant Task_Id
:= STPO
.Self
;
233 Activate_Prio
: System
.Any_Priority
;
237 pragma Assert
(Self_ID
= Environment_Task
);
238 pragma Assert
(Self_ID
.Common
.Wait_Count
= 0);
244 -- Lock self, to prevent activated tasks
245 -- from racing ahead before we finish activating the chain.
247 Write_Lock
(Self_ID
);
249 -- Activate all the tasks in the chain.
250 -- Creation of the thread of control was deferred until
251 -- activation. So create it now.
253 C
:= Chain_Access
.T_ID
;
256 if C
.Common
.State
/= Terminated
then
257 pragma Assert
(C
.Common
.State
= Unactivated
);
261 if C
.Common
.Base_Priority
< Get_Priority
(Self_ID
) then
262 Activate_Prio
:= Get_Priority
(Self_ID
);
264 Activate_Prio
:= C
.Common
.Base_Priority
;
268 (C
, Task_Wrapper
'Address,
270 (C
.Common
.Compiler_Data
.Pri_Stack_Info
.Size
),
271 Activate_Prio
, Success
);
273 Self_ID
.Common
.Wait_Count
:= Self_ID
.Common
.Wait_Count
+ 1;
276 C
.Common
.State
:= Runnable
;
284 C
:= C
.Common
.Activation_Link
;
287 Self_ID
.Common
.State
:= Activator_Sleep
;
289 -- Wait for the activated tasks to complete activation.
290 -- It is unsafe to abort any of these tasks until the count goes to
294 exit when Self_ID
.Common
.Wait_Count
= 0;
295 Sleep
(Self_ID
, Activator_Sleep
);
298 Self_ID
.Common
.State
:= Runnable
;
305 -- Remove the tasks from the chain.
307 Chain_Access
.T_ID
:= null;
308 end Activate_Restricted_Tasks
;
310 ------------------------------------
311 -- Complete_Restricted_Activation --
312 ------------------------------------
314 -- As in several other places, the locks of the activator and activated
315 -- task are both locked here. This follows our deadlock prevention lock
316 -- ordering policy, since the activated task must be created after the
319 procedure Complete_Restricted_Activation
is
320 Self_ID
: constant Task_Id
:= STPO
.Self
;
321 Activator
: constant Task_Id
:= Self_ID
.Common
.Activator
;
328 Write_Lock
(Activator
);
329 Write_Lock
(Self_ID
);
331 -- Remove dangling reference to Activator,
332 -- since a task may outlive its activator.
334 Self_ID
.Common
.Activator
:= null;
336 -- Wake up the activator, if it is waiting for a chain
337 -- of tasks to activate, and we are the last in the chain
338 -- to complete activation
340 if Activator
.Common
.State
= Activator_Sleep
then
341 Activator
.Common
.Wait_Count
:= Activator
.Common
.Wait_Count
- 1;
343 if Activator
.Common
.Wait_Count
= 0 then
344 Wakeup
(Activator
, Activator_Sleep
);
355 -- After the activation, active priority should be the same
356 -- as base priority. We must unlock the Activator first,
357 -- though, since it should not wait if we have lower priority.
359 if Get_Priority
(Self_ID
) /= Self_ID
.Common
.Base_Priority
then
360 Set_Priority
(Self_ID
, Self_ID
.Common
.Base_Priority
);
362 end Complete_Restricted_Activation
;
364 ------------------------------
365 -- Complete_Restricted_Task --
366 ------------------------------
368 procedure Complete_Restricted_Task
is
370 STPO
.Self
.Common
.State
:= Terminated
;
371 end Complete_Restricted_Task
;
373 ----------------------------
374 -- Create_Restricted_Task --
375 ----------------------------
377 procedure Create_Restricted_Task
379 Stack_Address
: System
.Address
;
380 Size
: System
.Parameters
.Size_Type
;
381 Task_Info
: System
.Task_Info
.Task_Info_Type
;
382 State
: Task_Procedure_Access
;
383 Discriminants
: System
.Address
;
384 Elaborated
: Access_Boolean
;
385 Chain
: in out Activation_Chain
;
387 Created_Task
: Task_Id
)
389 Self_ID
: constant Task_Id
:= STPO
.Self
;
390 Base_Priority
: System
.Any_Priority
;
394 -- Stack is not preallocated on this target, so that
395 -- Stack_Address must be null.
397 pragma Assert
(Stack_Address
= Null_Address
);
399 if Priority
= Unspecified_Priority
then
400 Base_Priority
:= Self_ID
.Common
.Base_Priority
;
402 Base_Priority
:= System
.Any_Priority
(Priority
);
409 Write_Lock
(Self_ID
);
411 -- With no task hierarchy, the parent of all non-Environment tasks that
412 -- are created must be the Environment task
415 (Self_ID
, State
, Discriminants
, Self_ID
, Elaborated
, Base_Priority
,
416 Task_Info
, Size
, Created_Task
, Success
);
418 -- If we do our job right then there should never be any failures,
419 -- which was probably said about the Titanic; so just to be safe,
420 -- let's retain this code for now
432 Created_Task
.Entry_Calls
(1).Self
:= Created_Task
;
434 Created_Task
.Common
.Task_Image_Len
:=
435 Integer'Min (Created_Task
.Common
.Task_Image
'Length, Task_Image
'Length);
436 Created_Task
.Common
.Task_Image
437 (1 .. Created_Task
.Common
.Task_Image_Len
) := Task_Image
;
445 -- Create TSD as early as possible in the creation of a task, since it
446 -- may be used by the operation of Ada code within the task.
448 SSL
.Create_TSD
(Created_Task
.Common
.Compiler_Data
);
449 Created_Task
.Common
.Activation_Link
:= Chain
.T_ID
;
450 Chain
.T_ID
:= Created_Task
;
451 end Create_Restricted_Task
;
453 ---------------------------
454 -- Finalize_Global_Tasks --
455 ---------------------------
457 -- This is needed to support the compiler interface; it will only be called
458 -- by the Environment task. Instead, it will cause the Environment to block
459 -- forever, since none of the dependent tasks are expected to terminate
461 procedure Finalize_Global_Tasks
is
462 Self_ID
: constant Task_Id
:= STPO
.Self
;
465 pragma Assert
(Self_ID
= STPO
.Environment_Task
);
471 Write_Lock
(Self_ID
);
472 Sleep
(Self_ID
, Master_Completion_Sleep
);
479 -- Should never return from Master Completion Sleep
482 end Finalize_Global_Tasks
;
484 ---------------------------
485 -- Restricted_Terminated --
486 ---------------------------
488 function Restricted_Terminated
(T
: Task_Id
) return Boolean is
490 return T
.Common
.State
= Terminated
;
491 end Restricted_Terminated
;
497 procedure Terminate_Task
(Self_ID
: Task_Id
) is
499 Self_ID
.Common
.State
:= Terminated
;
506 procedure Init_RTS
is
510 -- Initialize lock used to implement mutual exclusion between all tasks
512 STPO
.Initialize_Lock
(Global_Task_Lock
'Access, STPO
.Global_Task_Level
);
514 -- Notify that the tasking run time has been elaborated so that
515 -- the tasking version of the soft links can be used.
517 SSL
.Lock_Task
:= Task_Lock
'Access;
518 SSL
.Unlock_Task
:= Task_Unlock
'Access;
519 SSL
.Adafinal
:= Finalize_Global_Tasks
'Access;
521 -- Initialize the tasking soft links (if not done yet) that are common
522 -- to the full and the restricted run times.
524 SSL
.Tasking
.Init_Tasking_Soft_Links
;
529 end System
.Tasking
.Restricted
.Stages
;