Mercurial > hg > CbC > CbC_gcc
comparison gcc/ada/libgnarl/s-mudido__affinity.adb @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
comparison
equal
deleted
inserted
replaced
68:561a7518be6b | 111:04ced10e8804 |
---|---|
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; |