File : s-taskin-raven-cert.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
4 -- --
5 -- S Y S T E M . T A S K I N G --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT 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. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
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/>. --
26 -- --
27 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 -- This is the Ravenscar/cert version of this package
33
34 pragma Restrictions (No_Elaboration_Code);
35
36 pragma Polling (Off);
37 -- Turn off polling, we do not want ATC polling to take place during
38 -- tasking operations. It causes infinite loops and other problems.
39
40 with Ada.Exceptions.Is_Null_Occurrence;
41
42 with System.Task_Primitives.Operations;
43
44 package body System.Tasking is
45
46 use Ada.Exceptions;
47 use System.Multiprocessors;
48
49 package SSL renames System.Soft_Links;
50
51 ------------------------
52 -- Local Declarations --
53 ------------------------
54
55 Main_Priority : Integer;
56 pragma Import (C, Main_Priority, "__gl_main_priority");
57 -- Priority associated to the environment task. By default, its
58 -- value is undefined, and can be set by using pragma Priority in
59 -- the main program. This is a binder generated value (see s-init*.adb)
60
61 Main_CPU : Integer;
62 pragma Import (C, Main_CPU, "__gl_main_cpu");
63 -- Affinity associated with the environment task. By default, its value is
64 -- undefined, and can be set by using pragma CPU in the main program. Its
65 -- declaration in this variant is for uniformity with other variants of
66 -- s-taskin. This is a binder generated value (see s-init*.adb)
67
68 Environment : aliased Ada_Task_Control_Block (Entry_Num => 0);
69 -- ATCB for the environment task
70
71 subtype EOA is Ada.Exceptions.Exception_Occurrence_Access;
72
73 -----------------------
74 -- Local Subprograms --
75 -----------------------
76
77 function Get_Jmpbuf_Address return Address;
78 pragma Inline (Get_Jmpbuf_Address);
79
80 procedure Set_Jmpbuf_Address (Addr : Address);
81 pragma Inline (Set_Jmpbuf_Address);
82
83 function Get_Sec_Stack_Addr return Address;
84 pragma Inline (Get_Sec_Stack_Addr);
85
86 procedure Set_Sec_Stack_Addr (Addr : Address);
87 pragma Inline (Set_Sec_Stack_Addr);
88
89 function Get_Current_Excep return EOA;
90 pragma Inline (Get_Current_Excep);
91
92 ---------------------
93 -- Initialize_ATCB --
94 ---------------------
95
96 procedure Initialize_ATCB
97 (Task_Entry_Point : Task_Procedure_Access;
98 Task_Arg : System.Address;
99 Base_Priority : System.Any_Priority;
100 Base_CPU : System.Multiprocessors.CPU_Range;
101 Task_Info : System.Task_Info.Task_Info_Type;
102 Stack_Address : System.Address;
103 Stack_Size : System.Parameters.Size_Type;
104 T : Task_Id;
105 Success : out Boolean)
106 is
107 begin
108 T.Common.State := Unactivated;
109
110 -- Initialize T.Common.LL
111
112 Task_Primitives.Operations.Initialize_TCB (T, Success);
113
114 if not Success then
115 return;
116 end if;
117
118 T.Common.Base_Priority := Base_Priority;
119 T.Common.Base_CPU := Base_CPU;
120 T.Common.Protected_Action_Nesting := 0;
121 T.Common.Task_Arg := Task_Arg;
122 T.Common.Task_Entry_Point := Task_Entry_Point;
123 T.Common.Task_Info := Task_Info;
124
125 T.Common.Compiler_Data.Pri_Stack_Info.Start_Address :=
126 Stack_Address;
127
128 T.Common.Compiler_Data.Pri_Stack_Info.Size :=
129 Storage_Elements.Storage_Offset
130 (Parameters.Adjust_Storage_Size (Stack_Size));
131 end Initialize_ATCB;
132
133 ----------------
134 -- Initialize --
135 ----------------
136
137 Initialized : Boolean := False;
138 -- Used to prevent multiple calls to Initialize
139
140 procedure Initialize is
141 Base_Priority : Any_Priority;
142 Base_CPU : System.Multiprocessors.CPU;
143
144 Success : Boolean;
145
146 CPU_Not_In_Range : Boolean := False;
147
148 begin
149 if Initialized then
150 return;
151 end if;
152
153 Initialized := True;
154
155 -- Legal values of CPU are the special Unspecified_CPU value which is
156 -- inserted by the compiler for tasks without CPU aspect, and those in
157 -- the range of CPU_Range but no greater than Number_Of_CPUs. Otherwise
158 -- the task is defined to have failed, and it becomes a completed task
159 -- (RM D.16(14/3)).
160
161 if Main_CPU /= Unspecified_CPU
162 and then (Main_CPU < Integer (System.Multiprocessors.CPU_Range'First)
163 or else
164 Main_CPU > Integer (System.Multiprocessors.Number_Of_CPUs))
165 then
166 -- Delay the exception until the environment task is initialized
167
168 CPU_Not_In_Range := True;
169
170 -- Use the current CPU as Main_CPU
171
172 Base_CPU := CPU'First; -- Default CPU
173
174 else
175 Base_CPU :=
176 (if Main_CPU = Unspecified_CPU
177 or else CPU_Range (Main_CPU) = Not_A_Specific_CPU
178 then CPU'First -- Default CPU
179 else CPU (Main_CPU));
180 end if;
181
182 -- Set Main_CPU with the selected CPU value
183 -- (instead of Unspecified_CPU or Not_A_Specific_CPU)
184
185 Main_CPU := Integer (Base_CPU);
186
187 Base_Priority :=
188 (if Main_Priority = Unspecified_Priority
189 then Default_Priority
190 else Main_Priority);
191
192 Initialize_ATCB
193 (null, Null_Address, Base_Priority, Base_CPU,
194 Task_Info.Unspecified_Task_Info, Null_Address, 0,
195 Environment'Access, Success);
196 pragma Assert (Success);
197
198 Task_Primitives.Operations.Initialize (Environment'Access);
199
200 Task_Primitives.Operations.Set_Priority
201 (Environment'Access, Base_Priority);
202
203 Environment.Common.State := Runnable;
204 Environment.Entry_Call.Self := Environment'Access;
205
206 -- Initialize the secondary stack
207
208 Environment.Common.Compiler_Data.Sec_Stack_Addr :=
209 System.Soft_Links.Get_Sec_Stack_Addr_NT;
210
211 SSL.Get_Jmpbuf_Address := Get_Jmpbuf_Address'Access;
212 SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access;
213 SSL.Get_Current_Excep := Get_Current_Excep'Access;
214 SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access;
215 SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access;
216
217 if CPU_Not_In_Range then
218 raise Tasking_Error with "Main CPU not in range";
219 end if;
220 end Initialize;
221
222 ----------
223 -- Self --
224 ----------
225
226 function Self return Task_Id renames System.Task_Primitives.Operations.Self;
227
228 ------------------
229 -- Storage_Size --
230 ------------------
231
232 function Storage_Size (T : Task_Id) return System.Parameters.Size_Type is
233 begin
234 return
235 System.Parameters.Size_Type
236 (T.Common.Compiler_Data.Pri_Stack_Info.Size);
237 end Storage_Size;
238
239 -----------------------
240 -- Get_Current_Excep --
241 -----------------------
242
243 function Get_Current_Excep return EOA is
244 Self_ID : constant Task_Id := Self;
245 begin
246 return Self_ID.Common.Compiler_Data.Current_Excep'Access;
247 end Get_Current_Excep;
248
249 ------------------------
250 -- Get_Jmpbuf_Address --
251 ------------------------
252
253 function Get_Jmpbuf_Address return Address is
254 Self_ID : constant Task_Id := Self;
255 begin
256 return Self_ID.Common.Compiler_Data.Jmpbuf_Address;
257 end Get_Jmpbuf_Address;
258
259 ------------------------
260 -- Get_Sec_Stack_Addr --
261 ------------------------
262
263 function Get_Sec_Stack_Addr return Address is
264 Self_ID : constant Task_Id := Self;
265 begin
266 return Self_ID.Common.Compiler_Data.Sec_Stack_Addr;
267 end Get_Sec_Stack_Addr;
268
269 ------------------------
270 -- Set_Jmpbuf_Address --
271 ------------------------
272
273 procedure Set_Jmpbuf_Address (Addr : Address) is
274 Self_ID : constant Task_Id := Self;
275 begin
276 Self_ID.Common.Compiler_Data.Jmpbuf_Address := Addr;
277 end Set_Jmpbuf_Address;
278
279 ------------------------
280 -- Set_Sec_Stack_Addr --
281 ------------------------
282
283 procedure Set_Sec_Stack_Addr (Addr : Address) is
284 Self_ID : constant Task_Id := Self;
285 begin
286 Self_ID.Common.Compiler_Data.Sec_Stack_Addr := Addr;
287 end Set_Sec_Stack_Addr;
288
289 end System.Tasking;