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------------------------------------------------------------------------------ 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 subtype Rng is CPU_Range range 125 Get_First_CPU (ST_DD'Unrestricted_Access) .. 126 Get_Last_CPU (ST_DD'Unrestricted_Access); 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 New_Domain : Dispatching_Domain; 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 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"; 159 160 elsif Self /= Environment_Task then 161 raise Dispatching_Domain_Error with 162 "only the environment task can create dispatching domains"; 163 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; 168 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; 176 177 New_System_Domain (Rng) := New_System_Domain (Rng) and not ST_DD; 178 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; 183 184 New_Domain := new ST.Dispatching_Domain'(ST_DD); 185 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. 189 190 ST.Initialization.Defer_Abort (Self); 191 192 Lock_RTS; 193 194 ST.System_Domain (Rng) := New_System_Domain (Rng); 195 pragma Assert (ST.System_Domain.all = New_System_Domain); 196 197 -- Iterate the list of tasks belonging to the default system 198 -- dispatching domain and set the appropriate affinity. 199 200 T := ST.All_Tasks_List; 201 202 while T /= null loop 203 if T.Common.Domain = ST.System_Domain then 204 Set_Task_Affinity (T); 205 end if; 206 207 T := T.Common.All_Tasks_Link; 208 end loop; 209 210 Unlock_RTS; 211 212 ST.Initialization.Undefer_Abort (Self); 213 214 return New_Domain; 215 end Create; 216 217 ----------------------------- 218 -- Delay_Until_And_Set_CPU -- 219 ----------------------------- 220 221 procedure Delay_Until_And_Set_CPU 222 (Delay_Until_Time : Ada.Real_Time.Time; 223 CPU : CPU_Range) 224 is 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. 229 230 delay until Delay_Until_Time; 231 Set_CPU (CPU); 232 end Delay_Until_And_Set_CPU; 233 234 -------------------------------- 235 -- Freeze_Dispatching_Domains -- 236 -------------------------------- 237 238 procedure Freeze_Dispatching_Domains is 239 begin 240 -- Signal the end of the elaboration code 241 242 ST.Dispatching_Domains_Frozen := True; 243 end Freeze_Dispatching_Domains; 244 245 ------------- 246 -- Get_CPU -- 247 ------------- 248 249 function Get_CPU 250 (T : Ada.Task_Identification.Task_Id := 251 Ada.Task_Identification.Current_Task) return CPU_Range 252 is 253 begin 254 return Convert_Ids (T).Common.Base_CPU; 255 end Get_CPU; 256 257 ----------------- 258 -- Get_CPU_Set -- 259 ----------------- 260 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; 265 266 ---------------------------- 267 -- Get_Dispatching_Domain -- 268 ---------------------------- 269 270 function Get_Dispatching_Domain 271 (T : Ada.Task_Identification.Task_Id := 272 Ada.Task_Identification.Current_Task) return Dispatching_Domain 273 is 274 begin 275 return Result : constant Dispatching_Domain := 276 Dispatching_Domain (Convert_Ids (T).Common.Domain) 277 do 278 pragma Assert (Result /= null); 279 end return; 280 end Get_Dispatching_Domain; 281 282 ------------------- 283 -- Get_First_CPU -- 284 ------------------- 285 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; 293 294 return CPU'First; 295 end Get_First_CPU; 296 297 ------------------ 298 -- Get_Last_CPU -- 299 ------------------ 300 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; 308 309 return CPU_Range'First; 310 end Get_Last_CPU; 311 312 ------------- 313 -- Set_CPU -- 314 ------------- 315 316 procedure Set_CPU 317 (CPU : CPU_Range; 318 T : Ada.Task_Identification.Task_Id := 319 Ada.Task_Identification.Current_Task) 320 is 321 Target : constant ST.Task_Id := Convert_Ids (T); 322 323 use type ST.Dispatching_Domain_Access; 324 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). 329 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; 337 338 Unchecked_Set_Affinity (Target.Common.Domain, CPU, Target); 339 end Set_CPU; 340 341 ---------------------------- 342 -- Unchecked_Set_Affinity -- 343 ---------------------------- 344 345 procedure Unchecked_Set_Affinity 346 (Domain : ST.Dispatching_Domain_Access; 347 CPU : CPU_Range; 348 T : ST.Task_Id) 349 is 350 Source_CPU : constant CPU_Range := T.Common.Base_CPU; 351 352 use type ST.Dispatching_Domain_Access; 353 354 begin 355 Write_Lock (T); 356 357 -- Move to the new domain 358 359 T.Common.Domain := Domain; 360 361 -- Attach the CPU to the task 362 363 T.Common.Base_CPU := CPU; 364 365 -- Change the number of tasks attached to a given task in the system 366 -- domain if needed. 367 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. 373 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; 378 379 -- Increase the number of tasks attached to the CPU to which this 380 -- task is being moved, if needed. 381 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; 387 388 -- Change the actual affinity calling the operating system level 389 390 Set_Task_Affinity (T); 391 392 Unlock (T); 393 end Unchecked_Set_Affinity; 394 395end System.Multiprocessors.Dispatching_Domains; 396