2015-05-12 Robert Dewar <dewar@adacore.com>
[official-gcc.git] / gcc / ada / s-mudido-affinity.adb
blob05e27719082c1b63bb1a375f33364a2c473d8f5a
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME COMPONENTS --
4 -- --
5 -- SYSTEM.MULTIPROCESSORS.DISPATCHING_DOMAINS --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2011-2014, 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 ------------------------------------------------------------------------------
32 -- Body used on targets where the operating system supports setting task
33 -- affinities.
35 with System.Tasking.Initialization;
36 with System.Task_Primitives.Operations; use System.Task_Primitives.Operations;
38 with Ada.Unchecked_Conversion;
40 package body System.Multiprocessors.Dispatching_Domains is
42 package ST renames System.Tasking;
44 -----------------------
45 -- Local subprograms --
46 -----------------------
48 function Convert_Ids is new
49 Ada.Unchecked_Conversion (Ada.Task_Identification.Task_Id, ST.Task_Id);
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).
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.
68 -----------------
69 -- Assign_Task --
70 -----------------
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)
78 Target : constant ST.Task_Id := Convert_Ids (T);
80 use type ST.Dispatching_Domain_Access;
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).
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";
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;
98 -- Assigning a task to System_Dispatching_Domain that is already
99 -- assigned to that domain has no effect.
101 if Domain = System_Dispatching_Domain then
102 return;
104 else
105 -- Set the task affinity once we know it is possible
107 Unchecked_Set_Affinity
108 (ST.Dispatching_Domain_Access (Domain), CPU, Target);
109 end if;
110 end Assign_Task;
112 ------------
113 -- Create --
114 ------------
116 function Create (First : CPU; Last : CPU_Range) return Dispatching_Domain is
117 begin
118 return Create ((First .. Last => True));
119 end Create;
121 function Create (Set : CPU_Set) return Dispatching_Domain is
122 ST_DD : aliased constant ST.Dispatching_Domain
123 := ST.Dispatching_Domain (Set);
124 subtype Rng is CPU_Range range
125 Get_First_CPU (ST_DD'Unrestricted_Access) ..
126 Get_Last_CPU (ST_DD'Unrestricted_Access);
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;
133 T : ST.Task_Id;
135 New_System_Domain : ST.Dispatching_Domain := ST.System_Domain.all;
137 New_Domain : Dispatching_Domain;
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.
150 -- Note that a previous version of the language forbade empty domains.
152 if Rng'Last > Number_Of_CPUs then
153 raise Dispatching_Domain_Error with
154 "CPU not supported by the target";
156 elsif (ST_DD and not ST.System_Domain (Rng)) /= (Rng => False) then
157 raise Dispatching_Domain_Error with
158 "CPU not currently in System_Dispatching_Domain";
160 elsif Self /= Environment_Task then
161 raise Dispatching_Domain_Error with
162 "only the environment task can create dispatching domains";
164 elsif ST.Dispatching_Domains_Frozen then
165 raise Dispatching_Domain_Error with
166 "cannot create dispatching domain after call to main procedure";
167 end if;
169 for Proc in Rng loop
170 if ST_DD (Proc) and then
171 ST.Dispatching_Domain_Tasks (Proc) /= 0
172 then
173 raise Dispatching_Domain_Error with "CPU has tasks assigned";
174 end if;
175 end loop;
177 New_System_Domain (Rng) := New_System_Domain (Rng) and not ST_DD;
179 if New_System_Domain = (New_System_Domain'Range => False) then
180 raise Dispatching_Domain_Error with
181 "would leave System_Dispatching_Domain empty";
182 end if;
184 New_Domain := new ST.Dispatching_Domain'(ST_DD);
186 -- At this point we need to fix the processors belonging to the system
187 -- domain, and change the affinity of every task that has been created
188 -- and assigned to the system domain.
190 ST.Initialization.Defer_Abort (Self);
192 Lock_RTS;
194 ST.System_Domain (Rng) := New_System_Domain (Rng);
195 pragma Assert (ST.System_Domain.all = New_System_Domain);
197 -- Iterate the list of tasks belonging to the default system
198 -- dispatching domain and set the appropriate affinity.
200 T := ST.All_Tasks_List;
202 while T /= null loop
203 if T.Common.Domain = ST.System_Domain then
204 Set_Task_Affinity (T);
205 end if;
207 T := T.Common.All_Tasks_Link;
208 end loop;
210 Unlock_RTS;
212 ST.Initialization.Undefer_Abort (Self);
214 return New_Domain;
215 end Create;
217 -----------------------------
218 -- Delay_Until_And_Set_CPU --
219 -----------------------------
221 procedure Delay_Until_And_Set_CPU
222 (Delay_Until_Time : Ada.Real_Time.Time;
223 CPU : CPU_Range)
225 begin
226 -- Not supported atomically by the underlying operating systems.
227 -- Operating systems use to migrate the task immediately after the call
228 -- to set the affinity.
230 delay until Delay_Until_Time;
231 Set_CPU (CPU);
232 end Delay_Until_And_Set_CPU;
234 --------------------------------
235 -- Freeze_Dispatching_Domains --
236 --------------------------------
238 procedure Freeze_Dispatching_Domains is
239 begin
240 -- Signal the end of the elaboration code
242 ST.Dispatching_Domains_Frozen := True;
243 end Freeze_Dispatching_Domains;
245 -------------
246 -- Get_CPU --
247 -------------
249 function Get_CPU
250 (T : Ada.Task_Identification.Task_Id :=
251 Ada.Task_Identification.Current_Task) return CPU_Range
253 begin
254 return Convert_Ids (T).Common.Base_CPU;
255 end Get_CPU;
257 -----------------
258 -- Get_CPU_Set --
259 -----------------
261 function Get_CPU_Set (Domain : Dispatching_Domain) return CPU_Set is
262 begin
263 return CPU_Set (Domain.all);
264 end Get_CPU_Set;
266 ----------------------------
267 -- Get_Dispatching_Domain --
268 ----------------------------
270 function Get_Dispatching_Domain
271 (T : Ada.Task_Identification.Task_Id :=
272 Ada.Task_Identification.Current_Task) return Dispatching_Domain
274 begin
275 return Result : constant Dispatching_Domain :=
276 Dispatching_Domain (Convert_Ids (T).Common.Domain)
278 pragma Assert (Result /= null);
279 end return;
280 end Get_Dispatching_Domain;
282 -------------------
283 -- Get_First_CPU --
284 -------------------
286 function Get_First_CPU (Domain : Dispatching_Domain) return CPU is
287 begin
288 for Proc in Domain'Range loop
289 if Domain (Proc) then
290 return Proc;
291 end if;
292 end loop;
294 return CPU'First;
295 end Get_First_CPU;
297 ------------------
298 -- Get_Last_CPU --
299 ------------------
301 function Get_Last_CPU (Domain : Dispatching_Domain) return CPU_Range is
302 begin
303 for Proc in reverse Domain'Range loop
304 if Domain (Proc) then
305 return Proc;
306 end if;
307 end loop;
309 return CPU_Range'First;
310 end Get_Last_CPU;
312 -------------
313 -- Set_CPU --
314 -------------
316 procedure Set_CPU
317 (CPU : CPU_Range;
318 T : Ada.Task_Identification.Task_Id :=
319 Ada.Task_Identification.Current_Task)
321 Target : constant ST.Task_Id := Convert_Ids (T);
323 use type ST.Dispatching_Domain_Access;
325 begin
326 -- The exception Dispatching_Domain_Error is propagated if CPU is not
327 -- one of the processors of the Dispatching_Domain on which T is
328 -- assigned (and is not Not_A_Specific_CPU).
330 if CPU /= Not_A_Specific_CPU and then
331 (CPU not in Target.Common.Domain'Range or else
332 not Target.Common.Domain (CPU))
333 then
334 raise Dispatching_Domain_Error with
335 "processor does not belong to the task's dispatching domain";
336 end if;
338 Unchecked_Set_Affinity (Target.Common.Domain, CPU, Target);
339 end Set_CPU;
341 ----------------------------
342 -- Unchecked_Set_Affinity --
343 ----------------------------
345 procedure Unchecked_Set_Affinity
346 (Domain : ST.Dispatching_Domain_Access;
347 CPU : CPU_Range;
348 T : ST.Task_Id)
350 Source_CPU : constant CPU_Range := T.Common.Base_CPU;
352 use type ST.Dispatching_Domain_Access;
354 begin
355 Write_Lock (T);
357 -- Move to the new domain
359 T.Common.Domain := Domain;
361 -- Attach the CPU to the task
363 T.Common.Base_CPU := CPU;
365 -- Change the number of tasks attached to a given task in the system
366 -- domain if needed.
368 if not ST.Dispatching_Domains_Frozen
369 and then (Domain = null or else Domain = ST.System_Domain)
370 then
371 -- Reduce the number of tasks attached to the CPU from which this
372 -- task is being moved, if needed.
374 if Source_CPU /= Not_A_Specific_CPU then
375 ST.Dispatching_Domain_Tasks (Source_CPU) :=
376 ST.Dispatching_Domain_Tasks (Source_CPU) - 1;
377 end if;
379 -- Increase the number of tasks attached to the CPU to which this
380 -- task is being moved, if needed.
382 if CPU /= Not_A_Specific_CPU then
383 ST.Dispatching_Domain_Tasks (CPU) :=
384 ST.Dispatching_Domain_Tasks (CPU) + 1;
385 end if;
386 end if;
388 -- Change the actual affinity calling the operating system level
390 Set_Task_Affinity (T);
392 Unlock (T);
393 end Unchecked_Set_Affinity;
395 end System.Multiprocessors.Dispatching_Domains;