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-- 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 35with System.Tasking.Initialization; 36with System.Task_Primitives.Operations; use System.Task_Primitives.Operations; 37 38with Ada.Unchecked_Conversion; 39 40package 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 406end System.Multiprocessors.Dispatching_Domains; 407