|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT RUN-TIME COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- SYSTEM.MULTIPROCESSORS.DISPATCHING_DOMAINS --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
|
9 -- Copyright (C) 2011-2017, Free Software Foundation, Inc. --
|
|
|
10 -- --
|
|
|
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. --
|
|
|
17 -- --
|
|
|
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. --
|
|
|
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 -- Body used on targets where the operating system supports setting task
|
|
|
33 -- affinities.
|
|
|
34
|
|
|
35 with System.Tasking.Initialization;
|
|
|
36 with System.Task_Primitives.Operations; use System.Task_Primitives.Operations;
|
|
|
37
|
|
|
38 with Ada.Unchecked_Conversion;
|
|
|
39
|
|
|
40 package body System.Multiprocessors.Dispatching_Domains is
|
|
|
41
|
|
|
42 package ST renames System.Tasking;
|
|
|
43
|
|
|
44 -----------------------
|
|
|
45 -- Local subprograms --
|
|
|
46 -----------------------
|
|
|
47
|
|
|
48 function Convert_Ids is new
|
|
|
49 Ada.Unchecked_Conversion (Ada.Task_Identification.Task_Id, ST.Task_Id);
|
|
|
50
|
|
|
51 procedure Unchecked_Set_Affinity
|
|
|
52 (Domain : ST.Dispatching_Domain_Access;
|
|
|
53 CPU : CPU_Range;
|
|
|
54 T : ST.Task_Id);
|
|
|
55 -- Internal procedure to move a task to a target domain and CPU. No checks
|
|
|
56 -- are performed about the validity of the domain and the CPU because they
|
|
|
57 -- are done by the callers of this procedure (either Assign_Task or
|
|
|
58 -- Set_CPU).
|
|
|
59
|
|
|
60 procedure Freeze_Dispatching_Domains;
|
|
|
61 pragma Export
|
|
|
62 (Ada, Freeze_Dispatching_Domains, "__gnat_freeze_dispatching_domains");
|
|
|
63 -- Signal the time when no new dispatching domains can be created. It
|
|
|
64 -- should be called before the environment task calls the main procedure
|
|
|
65 -- (and after the elaboration code), so the binder-generated file needs to
|
|
|
66 -- import and call this procedure.
|
|
|
67
|
|
|
68 -----------------
|
|
|
69 -- Assign_Task --
|
|
|
70 -----------------
|
|
|
71
|
|
|
72 procedure Assign_Task
|
|
|
73 (Domain : in out Dispatching_Domain;
|
|
|
74 CPU : CPU_Range := Not_A_Specific_CPU;
|
|
|
75 T : Ada.Task_Identification.Task_Id :=
|
|
|
76 Ada.Task_Identification.Current_Task)
|
|
|
77 is
|
|
|
78 Target : constant ST.Task_Id := Convert_Ids (T);
|
|
|
79
|
|
|
80 begin
|
|
|
81 -- The exception Dispatching_Domain_Error is propagated if T is already
|
|
|
82 -- assigned to a Dispatching_Domain other than
|
|
|
83 -- System_Dispatching_Domain, or if CPU is not one of the processors of
|
|
|
84 -- Domain (and is not Not_A_Specific_CPU).
|
|
|
85
|
|
|
86 if Dispatching_Domain (Target.Common.Domain) /= System_Dispatching_Domain
|
|
|
87 then
|
|
|
88 raise Dispatching_Domain_Error with
|
|
|
89 "task already in user-defined dispatching domain";
|
|
|
90
|
|
|
91 elsif CPU /= Not_A_Specific_CPU and then CPU not in Domain'Range then
|
|
|
92 raise Dispatching_Domain_Error with
|
|
|
93 "processor does not belong to dispatching domain";
|
|
|
94 end if;
|
|
|
95
|
|
|
96 -- Assigning a task to System_Dispatching_Domain that is already
|
|
|
97 -- assigned to that domain has no effect.
|
|
|
98
|
|
|
99 if Domain = System_Dispatching_Domain then
|
|
|
100 return;
|
|
|
101
|
|
|
102 else
|
|
|
103 -- Set the task affinity once we know it is possible
|
|
|
104
|
|
|
105 Unchecked_Set_Affinity
|
|
|
106 (ST.Dispatching_Domain_Access (Domain), CPU, Target);
|
|
|
107 end if;
|
|
|
108 end Assign_Task;
|
|
|
109
|
|
|
110 ------------
|
|
|
111 -- Create --
|
|
|
112 ------------
|
|
|
113
|
|
|
114 function Create (First : CPU; Last : CPU_Range) return Dispatching_Domain is
|
|
|
115 begin
|
|
|
116 return Create ((First .. Last => True));
|
|
|
117 end Create;
|
|
|
118
|
|
|
119 function Create (Set : CPU_Set) return Dispatching_Domain is
|
|
|
120 ST_DD : aliased constant ST.Dispatching_Domain :=
|
|
|
121 ST.Dispatching_Domain (Set);
|
|
|
122 First : constant CPU := Get_First_CPU (ST_DD'Unrestricted_Access);
|
|
|
123 Last : constant CPU_Range := Get_Last_CPU (ST_DD'Unrestricted_Access);
|
|
|
124 subtype Rng is CPU_Range range First .. Last;
|
|
|
125
|
|
|
126 use type ST.Dispatching_Domain;
|
|
|
127 use type ST.Dispatching_Domain_Access;
|
|
|
128 use type ST.Task_Id;
|
|
|
129
|
|
|
130 T : ST.Task_Id;
|
|
|
131
|
|
|
132 New_System_Domain : ST.Dispatching_Domain := ST.System_Domain.all;
|
|
|
133
|
|
|
134 ST_DD_Slice : constant ST.Dispatching_Domain := ST_DD (Rng);
|
|
|
135
|
|
|
136 begin
|
|
|
137 -- The set of processors for creating a dispatching domain must
|
|
|
138 -- comply with the following restrictions:
|
|
|
139 -- - Not exceeding the range of available processors.
|
|
|
140 -- - CPUs from the System_Dispatching_Domain.
|
|
|
141 -- - The calling task must be the environment task.
|
|
|
142 -- - The call to Create must take place before the call to the main
|
|
|
143 -- subprogram.
|
|
|
144 -- - Set does not contain a processor with a task assigned to it.
|
|
|
145 -- - The allocation cannot leave System_Dispatching_Domain empty.
|
|
|
146
|
|
|
147 -- Note that a previous version of the language forbade empty domains.
|
|
|
148
|
|
|
149 if Rng'Last > Number_Of_CPUs then
|
|
|
150 raise Dispatching_Domain_Error with
|
|
|
151 "CPU not supported by the target";
|
|
|
152 end if;
|
|
|
153
|
|
|
154 declare
|
|
|
155 System_Domain_Slice : constant ST.Dispatching_Domain :=
|
|
|
156 ST.System_Domain (Rng);
|
|
|
157 Actual : constant ST.Dispatching_Domain :=
|
|
|
158 ST_DD_Slice and not System_Domain_Slice;
|
|
|
159 Expected : constant ST.Dispatching_Domain := (Rng => False);
|
|
|
160 begin
|
|
|
161 if Actual /= Expected then
|
|
|
162 raise Dispatching_Domain_Error with
|
|
|
163 "CPU not currently in System_Dispatching_Domain";
|
|
|
164 end if;
|
|
|
165 end;
|
|
|
166
|
|
|
167 if Self /= Environment_Task then
|
|
|
168 raise Dispatching_Domain_Error with
|
|
|
169 "only the environment task can create dispatching domains";
|
|
|
170 end if;
|
|
|
171
|
|
|
172 if ST.Dispatching_Domains_Frozen then
|
|
|
173 raise Dispatching_Domain_Error with
|
|
|
174 "cannot create dispatching domain after call to main procedure";
|
|
|
175 end if;
|
|
|
176
|
|
|
177 for Proc in Rng loop
|
|
|
178 if ST_DD (Proc) and then
|
|
|
179 ST.Dispatching_Domain_Tasks (Proc) /= 0
|
|
|
180 then
|
|
|
181 raise Dispatching_Domain_Error with "CPU has tasks assigned";
|
|
|
182 end if;
|
|
|
183 end loop;
|
|
|
184
|
|
|
185 New_System_Domain (Rng) := New_System_Domain (Rng) and not ST_DD_Slice;
|
|
|
186
|
|
|
187 if New_System_Domain = (New_System_Domain'Range => False) then
|
|
|
188 raise Dispatching_Domain_Error with
|
|
|
189 "would leave System_Dispatching_Domain empty";
|
|
|
190 end if;
|
|
|
191
|
|
|
192 return Result : constant Dispatching_Domain :=
|
|
|
193 new ST.Dispatching_Domain'(ST_DD_Slice)
|
|
|
194 do
|
|
|
195 -- At this point we need to fix the processors belonging to the
|
|
|
196 -- system domain, and change the affinity of every task that has
|
|
|
197 -- been created and assigned to the system domain.
|
|
|
198
|
|
|
199 ST.Initialization.Defer_Abort (Self);
|
|
|
200
|
|
|
201 Lock_RTS;
|
|
|
202
|
|
|
203 ST.System_Domain (Rng) := New_System_Domain (Rng);
|
|
|
204 pragma Assert (ST.System_Domain.all = New_System_Domain);
|
|
|
205
|
|
|
206 -- Iterate the list of tasks belonging to the default system
|
|
|
207 -- dispatching domain and set the appropriate affinity.
|
|
|
208
|
|
|
209 T := ST.All_Tasks_List;
|
|
|
210
|
|
|
211 while T /= null loop
|
|
|
212 if T.Common.Domain = ST.System_Domain then
|
|
|
213 Set_Task_Affinity (T);
|
|
|
214 end if;
|
|
|
215
|
|
|
216 T := T.Common.All_Tasks_Link;
|
|
|
217 end loop;
|
|
|
218
|
|
|
219 Unlock_RTS;
|
|
|
220
|
|
|
221 ST.Initialization.Undefer_Abort (Self);
|
|
|
222 end return;
|
|
|
223 end Create;
|
|
|
224
|
|
|
225 -----------------------------
|
|
|
226 -- Delay_Until_And_Set_CPU --
|
|
|
227 -----------------------------
|
|
|
228
|
|
|
229 procedure Delay_Until_And_Set_CPU
|
|
|
230 (Delay_Until_Time : Ada.Real_Time.Time;
|
|
|
231 CPU : CPU_Range)
|
|
|
232 is
|
|
|
233 begin
|
|
|
234 -- Not supported atomically by the underlying operating systems.
|
|
|
235 -- Operating systems use to migrate the task immediately after the call
|
|
|
236 -- to set the affinity.
|
|
|
237
|
|
|
238 delay until Delay_Until_Time;
|
|
|
239 Set_CPU (CPU);
|
|
|
240 end Delay_Until_And_Set_CPU;
|
|
|
241
|
|
|
242 --------------------------------
|
|
|
243 -- Freeze_Dispatching_Domains --
|
|
|
244 --------------------------------
|
|
|
245
|
|
|
246 procedure Freeze_Dispatching_Domains is
|
|
|
247 begin
|
|
|
248 -- Signal the end of the elaboration code
|
|
|
249
|
|
|
250 ST.Dispatching_Domains_Frozen := True;
|
|
|
251 end Freeze_Dispatching_Domains;
|
|
|
252
|
|
|
253 -------------
|
|
|
254 -- Get_CPU --
|
|
|
255 -------------
|
|
|
256
|
|
|
257 function Get_CPU
|
|
|
258 (T : Ada.Task_Identification.Task_Id :=
|
|
|
259 Ada.Task_Identification.Current_Task) return CPU_Range
|
|
|
260 is
|
|
|
261 begin
|
|
|
262 return Convert_Ids (T).Common.Base_CPU;
|
|
|
263 end Get_CPU;
|
|
|
264
|
|
|
265 -----------------
|
|
|
266 -- Get_CPU_Set --
|
|
|
267 -----------------
|
|
|
268
|
|
|
269 function Get_CPU_Set (Domain : Dispatching_Domain) return CPU_Set is
|
|
|
270 begin
|
|
|
271 return CPU_Set (Domain.all);
|
|
|
272 end Get_CPU_Set;
|
|
|
273
|
|
|
274 ----------------------------
|
|
|
275 -- Get_Dispatching_Domain --
|
|
|
276 ----------------------------
|
|
|
277
|
|
|
278 function Get_Dispatching_Domain
|
|
|
279 (T : Ada.Task_Identification.Task_Id :=
|
|
|
280 Ada.Task_Identification.Current_Task) return Dispatching_Domain
|
|
|
281 is
|
|
|
282 begin
|
|
|
283 return Result : constant Dispatching_Domain :=
|
|
|
284 Dispatching_Domain (Convert_Ids (T).Common.Domain)
|
|
|
285 do
|
|
|
286 pragma Assert (Result /= null);
|
|
|
287 end return;
|
|
|
288 end Get_Dispatching_Domain;
|
|
|
289
|
|
|
290 -------------------
|
|
|
291 -- Get_First_CPU --
|
|
|
292 -------------------
|
|
|
293
|
|
|
294 function Get_First_CPU (Domain : Dispatching_Domain) return CPU is
|
|
|
295 begin
|
|
|
296 for Proc in Domain'Range loop
|
|
|
297 if Domain (Proc) then
|
|
|
298 return Proc;
|
|
|
299 end if;
|
|
|
300 end loop;
|
|
|
301
|
|
|
302 return CPU'First;
|
|
|
303 end Get_First_CPU;
|
|
|
304
|
|
|
305 ------------------
|
|
|
306 -- Get_Last_CPU --
|
|
|
307 ------------------
|
|
|
308
|
|
|
309 function Get_Last_CPU (Domain : Dispatching_Domain) return CPU_Range is
|
|
|
310 begin
|
|
|
311 for Proc in reverse Domain'Range loop
|
|
|
312 if Domain (Proc) then
|
|
|
313 return Proc;
|
|
|
314 end if;
|
|
|
315 end loop;
|
|
|
316
|
|
|
317 return CPU_Range'First;
|
|
|
318 end Get_Last_CPU;
|
|
|
319
|
|
|
320 -------------
|
|
|
321 -- Set_CPU --
|
|
|
322 -------------
|
|
|
323
|
|
|
324 procedure Set_CPU
|
|
|
325 (CPU : CPU_Range;
|
|
|
326 T : Ada.Task_Identification.Task_Id :=
|
|
|
327 Ada.Task_Identification.Current_Task)
|
|
|
328 is
|
|
|
329 Target : constant ST.Task_Id := Convert_Ids (T);
|
|
|
330
|
|
|
331 begin
|
|
|
332 -- The exception Dispatching_Domain_Error is propagated if CPU is not
|
|
|
333 -- one of the processors of the Dispatching_Domain on which T is
|
|
|
334 -- assigned (and is not Not_A_Specific_CPU).
|
|
|
335
|
|
|
336 if CPU /= Not_A_Specific_CPU and then
|
|
|
337 (CPU not in Target.Common.Domain'Range or else
|
|
|
338 not Target.Common.Domain (CPU))
|
|
|
339 then
|
|
|
340 raise Dispatching_Domain_Error with
|
|
|
341 "processor does not belong to the task's dispatching domain";
|
|
|
342 end if;
|
|
|
343
|
|
|
344 Unchecked_Set_Affinity (Target.Common.Domain, CPU, Target);
|
|
|
345 end Set_CPU;
|
|
|
346
|
|
|
347 ----------------------------
|
|
|
348 -- Unchecked_Set_Affinity --
|
|
|
349 ----------------------------
|
|
|
350
|
|
|
351 procedure Unchecked_Set_Affinity
|
|
|
352 (Domain : ST.Dispatching_Domain_Access;
|
|
|
353 CPU : CPU_Range;
|
|
|
354 T : ST.Task_Id)
|
|
|
355 is
|
|
|
356 Source_CPU : constant CPU_Range := T.Common.Base_CPU;
|
|
|
357
|
|
|
358 use type ST.Dispatching_Domain_Access;
|
|
|
359
|
|
|
360 begin
|
|
|
361 Write_Lock (T);
|
|
|
362
|
|
|
363 -- Move to the new domain
|
|
|
364
|
|
|
365 T.Common.Domain := Domain;
|
|
|
366
|
|
|
367 -- Attach the CPU to the task
|
|
|
368
|
|
|
369 T.Common.Base_CPU := CPU;
|
|
|
370
|
|
|
371 -- Change the number of tasks attached to a given task in the system
|
|
|
372 -- domain if needed.
|
|
|
373
|
|
|
374 if not ST.Dispatching_Domains_Frozen
|
|
|
375 and then (Domain = null or else Domain = ST.System_Domain)
|
|
|
376 then
|
|
|
377 -- Reduce the number of tasks attached to the CPU from which this
|
|
|
378 -- task is being moved, if needed.
|
|
|
379
|
|
|
380 if Source_CPU /= Not_A_Specific_CPU then
|
|
|
381 ST.Dispatching_Domain_Tasks (Source_CPU) :=
|
|
|
382 ST.Dispatching_Domain_Tasks (Source_CPU) - 1;
|
|
|
383 end if;
|
|
|
384
|
|
|
385 -- Increase the number of tasks attached to the CPU to which this
|
|
|
386 -- task is being moved, if needed.
|
|
|
387
|
|
|
388 if CPU /= Not_A_Specific_CPU then
|
|
|
389 ST.Dispatching_Domain_Tasks (CPU) :=
|
|
|
390 ST.Dispatching_Domain_Tasks (CPU) + 1;
|
|
|
391 end if;
|
|
|
392 end if;
|
|
|
393
|
|
|
394 -- Change the actual affinity calling the operating system level
|
|
|
395
|
|
|
396 Set_Task_Affinity (T);
|
|
|
397
|
|
|
398 Unlock (T);
|
|
|
399 end Unchecked_Set_Affinity;
|
|
|
400
|
|
|
401 end System.Multiprocessors.Dispatching_Domains;
|
