1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- SYSTEM.MULTIPROCESSORS.DISPATCHING_DOMAINS --
9 -- Copyright (C) 2011, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
30 ------------------------------------------------------------------------------
32 -- Body used on targets where the operating system supports setting task
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;
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
60 procedure Freeze_Dispatching_Domains;
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.
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 System.Tasking.Dispatching_Domain_Access;
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 Target.Common.Domain /= null and then
89 Dispatching_Domain (Target.Common.Domain) /= System_Dispatching_Domain
91 raise Dispatching_Domain_Error with
92 "task already in user-defined dispatching domain";
94 elsif CPU /= Not_A_Specific_CPU and then CPU not in Domain'Range then
95 raise Dispatching_Domain_Error with
96 "processor does not belong to dispatching domain";
99 -- Assigning a task to System_Dispatching_Domain that is already
100 -- assigned to that domain has no effect.
102 if Domain = System_Dispatching_Domain then
106 -- Set the task affinity once we know it is possible
108 Unchecked_Set_Affinity
109 (ST.Dispatching_Domain_Access (Domain), CPU, Target);
117 function Create (First, Last : CPU) return Dispatching_Domain is
118 use type System.Tasking.Dispatching_Domain;
119 use type System.Tasking.Dispatching_Domain_Access;
120 use type System.Tasking.Array_Allocated_Tasks;
121 use type System.Tasking.Task_Id;
123 Valid_System_Domain : constant Boolean :=
126 not (System_Dispatching_Domain (CPU'First .. First - 1) =
127 (CPU'First .. First - 1 => False)))
128 or else (Last < Number_Of_CPUs
130 (System_Dispatching_Domain
131 (Last + 1 .. Number_Of_CPUs) =
132 (Last + 1 .. Number_Of_CPUs => False)));
133 -- Constant that indicates whether there would exist a non-empty system
134 -- dispatching domain after the creation of this dispatching domain.
138 New_Domain : Dispatching_Domain;
141 -- The range of processors for creating a dispatching domain must
142 -- comply with the following restrictions:
144 -- - Not exceeding the range of available processors
145 -- - Range from the System_Dispatching_Domain
146 -- - Range does not contain a processor with a task assigned to it
147 -- - The allocation cannot leave System_Dispatching_Domain empty
148 -- - The calling task must be the environment task
149 -- - The call to Create must take place before the call to the main
153 raise Dispatching_Domain_Error with "empty dispatching domain";
155 elsif Last > Number_Of_CPUs then
156 raise Dispatching_Domain_Error with
157 "CPU range not supported by the target";
160 System_Dispatching_Domain (First .. Last) /= (First .. Last => True)
162 raise Dispatching_Domain_Error with
163 "CPU range not currently in System_Dispatching_Domain";
166 ST.Dispatching_Domain_Tasks (First .. Last) /= (First .. Last => 0)
168 raise Dispatching_Domain_Error with "CPU range has tasks assigned";
170 elsif not Valid_System_Domain then
171 raise Dispatching_Domain_Error with
172 "would leave System_Dispatching_Domain empty";
174 elsif Self /= Environment_Task then
175 raise Dispatching_Domain_Error with
176 "only the environment task can create dispatching domains";
178 elsif ST.Dispatching_Domains_Frozen then
179 raise Dispatching_Domain_Error with
180 "cannot create dispatching domain after call to main program";
183 New_Domain := new ST.Dispatching_Domain'(First .. Last => True);
185 -- At this point we need to fix the processors belonging to the system
186 -- domain, and change the affinity of every task that has been created
187 -- and assigned to the system domain.
189 ST.Initialization.Defer_Abort (Self);
193 System_Dispatching_Domain (First .. Last) := (First .. Last => False);
195 -- Iterate the list of tasks belonging to the default system
196 -- dispatching domain and set the appropriate affinity.
198 T := ST.All_Tasks_List;
201 if T.Common.Domain = null or else
202 T.Common.Domain = ST.System_Domain
204 Set_Task_Affinity (T);
207 T := T.Common.All_Tasks_Link;
212 ST.Initialization.Undefer_Abort (Self);
217 -----------------------------
218 -- Delay_Until_And_Set_CPU --
219 -----------------------------
221 procedure Delay_Until_And_Set_CPU
222 (Delay_Until_Time : Ada.Real_Time.Time;
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;
232 end Delay_Until_And_Set_CPU;
234 --------------------------------
235 -- Freeze_Dispatching_Domains --
236 --------------------------------
238 procedure Freeze_Dispatching_Domains is
240 -- Signal the end of the elaboration code
242 ST.Dispatching_Domains_Frozen := True;
243 end Freeze_Dispatching_Domains;
250 (T : Ada.Task_Identification.Task_Id :=
251 Ada.Task_Identification.Current_Task) return CPU_Range
254 return Convert_Ids (T).Common.Base_CPU;
257 ----------------------------
258 -- Get_Dispatching_Domain --
259 ----------------------------
261 function Get_Dispatching_Domain
262 (T : Ada.Task_Identification.Task_Id :=
263 Ada.Task_Identification.Current_Task) return Dispatching_Domain
266 return Dispatching_Domain (Convert_Ids (T).Common.Domain);
267 end Get_Dispatching_Domain;
273 function Get_First_CPU (Domain : Dispatching_Domain) return CPU is
275 for Proc in Domain'Range loop
276 if Domain (Proc) then
281 -- Should never reach the following return
290 function Get_Last_CPU (Domain : Dispatching_Domain) return CPU is
292 for Proc in reverse Domain'Range loop
293 if Domain (Proc) then
298 -- Should never reach the following return
309 T : Ada.Task_Identification.Task_Id :=
310 Ada.Task_Identification.Current_Task)
312 Target : constant ST.Task_Id := Convert_Ids (T);
314 use type ST.Dispatching_Domain_Access;
317 -- The exception Dispatching_Domain_Error is propagated if CPU is not
318 -- one of the processors of the Dispatching_Domain on which T is
319 -- assigned (and is not Not_A_Specific_CPU).
321 if CPU /= Not_A_Specific_CPU and then
322 (CPU not in Target.Common.Domain'Range or else
323 not Target.Common.Domain (CPU))
325 raise Dispatching_Domain_Error with
326 "processor does not belong to the task's dispatching domain";
329 Unchecked_Set_Affinity (Target.Common.Domain, CPU, Target);
332 ----------------------------
333 -- Unchecked_Set_Affinity --
334 ----------------------------
336 procedure Unchecked_Set_Affinity
337 (Domain : ST.Dispatching_Domain_Access;
341 Source_CPU : constant CPU_Range := T.Common.Base_CPU;
343 use type System.Tasking.Dispatching_Domain_Access;
348 -- Move to the new domain
350 T.Common.Domain := Domain;
352 -- Attach the CPU to the task
354 T.Common.Base_CPU := CPU;
356 -- Change the number of tasks attached to a given task in the system
359 if not ST.Dispatching_Domains_Frozen
360 and then (Domain = null or else Domain = ST.System_Domain)
362 -- Reduce the number of tasks attached to the CPU from which this
363 -- task is being moved, if needed.
365 if Source_CPU /= Not_A_Specific_CPU then
366 ST.Dispatching_Domain_Tasks (Source_CPU) :=
367 ST.Dispatching_Domain_Tasks (Source_CPU) - 1;
370 -- Increase the number of tasks attached to the CPU to which this
371 -- task is being moved, if needed.
373 if CPU /= Not_A_Specific_CPU then
374 ST.Dispatching_Domain_Tasks (CPU) :=
375 ST.Dispatching_Domain_Tasks (CPU) + 1;
379 -- Change the actual affinity calling the operating system level
381 Set_Task_Affinity (T);
384 end Unchecked_Set_Affinity;
386 end System.Multiprocessors.Dispatching_Domains;