1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- SYSTEM.MULTIPROCESSORS.DISPATCHING_DOMAINS -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2011-2019, 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 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 401end System.Multiprocessors.Dispatching_Domains; 402