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