1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- SYSTEM.MULTIPROCESSORS.DISPATCHING_DOMAINS -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2011, 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 System.Tasking.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 Target.Common.Domain /= null and then 89 Dispatching_Domain (Target.Common.Domain) /= System_Dispatching_Domain 90 then 91 raise Dispatching_Domain_Error with 92 "task already in user-defined dispatching domain"; 93 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"; 97 end if; 98 99 -- Assigning a task to System_Dispatching_Domain that is already 100 -- assigned to that domain has no effect. 101 102 if Domain = System_Dispatching_Domain then 103 return; 104 105 else 106 -- Set the task affinity once we know it is possible 107 108 Unchecked_Set_Affinity 109 (ST.Dispatching_Domain_Access (Domain), CPU, Target); 110 end if; 111 end Assign_Task; 112 113 ------------ 114 -- Create -- 115 ------------ 116 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; 122 123 Valid_System_Domain : constant Boolean := 124 (First > CPU'First 125 and then 126 not (System_Dispatching_Domain (CPU'First .. First - 1) = 127 (CPU'First .. First - 1 => False))) 128 or else (Last < Number_Of_CPUs 129 and then not 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. 135 136 T : ST.Task_Id; 137 138 New_Domain : Dispatching_Domain; 139 140 begin 141 -- The range of processors for creating a dispatching domain must 142 -- comply with the following restrictions: 143 -- - Non-empty range 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 150 -- subprogram 151 152 if First > Last then 153 raise Dispatching_Domain_Error with "empty dispatching domain"; 154 155 elsif Last > Number_Of_CPUs then 156 raise Dispatching_Domain_Error with 157 "CPU range not supported by the target"; 158 159 elsif 160 System_Dispatching_Domain (First .. Last) /= (First .. Last => True) 161 then 162 raise Dispatching_Domain_Error with 163 "CPU range not currently in System_Dispatching_Domain"; 164 165 elsif 166 ST.Dispatching_Domain_Tasks (First .. Last) /= (First .. Last => 0) 167 then 168 raise Dispatching_Domain_Error with "CPU range has tasks assigned"; 169 170 elsif not Valid_System_Domain then 171 raise Dispatching_Domain_Error with 172 "would leave System_Dispatching_Domain empty"; 173 174 elsif Self /= Environment_Task then 175 raise Dispatching_Domain_Error with 176 "only the environment task can create dispatching domains"; 177 178 elsif ST.Dispatching_Domains_Frozen then 179 raise Dispatching_Domain_Error with 180 "cannot create dispatching domain after call to main program"; 181 end if; 182 183 New_Domain := new ST.Dispatching_Domain'(First .. Last => True); 184 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. 188 189 ST.Initialization.Defer_Abort (Self); 190 191 Lock_RTS; 192 193 System_Dispatching_Domain (First .. Last) := (First .. Last => False); 194 195 -- Iterate the list of tasks belonging to the default system 196 -- dispatching domain and set the appropriate affinity. 197 198 T := ST.All_Tasks_List; 199 200 while T /= null loop 201 if T.Common.Domain = null or else 202 T.Common.Domain = ST.System_Domain 203 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_Dispatching_Domain -- 259 ---------------------------- 260 261 function Get_Dispatching_Domain 262 (T : Ada.Task_Identification.Task_Id := 263 Ada.Task_Identification.Current_Task) return Dispatching_Domain 264 is 265 begin 266 return Dispatching_Domain (Convert_Ids (T).Common.Domain); 267 end Get_Dispatching_Domain; 268 269 ------------------- 270 -- Get_First_CPU -- 271 ------------------- 272 273 function Get_First_CPU (Domain : Dispatching_Domain) return CPU is 274 begin 275 for Proc in Domain'Range loop 276 if Domain (Proc) then 277 return Proc; 278 end if; 279 end loop; 280 281 -- Should never reach the following return 282 283 return Domain'First; 284 end Get_First_CPU; 285 286 ------------------ 287 -- Get_Last_CPU -- 288 ------------------ 289 290 function Get_Last_CPU (Domain : Dispatching_Domain) return CPU is 291 begin 292 for Proc in reverse Domain'Range loop 293 if Domain (Proc) then 294 return Proc; 295 end if; 296 end loop; 297 298 -- Should never reach the following return 299 300 return Domain'Last; 301 end Get_Last_CPU; 302 303 ------------- 304 -- Set_CPU -- 305 ------------- 306 307 procedure Set_CPU 308 (CPU : CPU_Range; 309 T : Ada.Task_Identification.Task_Id := 310 Ada.Task_Identification.Current_Task) 311 is 312 Target : constant ST.Task_Id := Convert_Ids (T); 313 314 use type ST.Dispatching_Domain_Access; 315 316 begin 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). 320 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)) 324 then 325 raise Dispatching_Domain_Error with 326 "processor does not belong to the task's dispatching domain"; 327 end if; 328 329 Unchecked_Set_Affinity (Target.Common.Domain, CPU, Target); 330 end Set_CPU; 331 332 ---------------------------- 333 -- Unchecked_Set_Affinity -- 334 ---------------------------- 335 336 procedure Unchecked_Set_Affinity 337 (Domain : ST.Dispatching_Domain_Access; 338 CPU : CPU_Range; 339 T : ST.Task_Id) 340 is 341 Source_CPU : constant CPU_Range := T.Common.Base_CPU; 342 343 use type System.Tasking.Dispatching_Domain_Access; 344 345 begin 346 Write_Lock (T); 347 348 -- Move to the new domain 349 350 T.Common.Domain := Domain; 351 352 -- Attach the CPU to the task 353 354 T.Common.Base_CPU := CPU; 355 356 -- Change the number of tasks attached to a given task in the system 357 -- domain if needed. 358 359 if not ST.Dispatching_Domains_Frozen 360 and then (Domain = null or else Domain = ST.System_Domain) 361 then 362 -- Reduce the number of tasks attached to the CPU from which this 363 -- task is being moved, if needed. 364 365 if Source_CPU /= Not_A_Specific_CPU then 366 ST.Dispatching_Domain_Tasks (Source_CPU) := 367 ST.Dispatching_Domain_Tasks (Source_CPU) - 1; 368 end if; 369 370 -- Increase the number of tasks attached to the CPU to which this 371 -- task is being moved, if needed. 372 373 if CPU /= Not_A_Specific_CPU then 374 ST.Dispatching_Domain_Tasks (CPU) := 375 ST.Dispatching_Domain_Tasks (CPU) + 1; 376 end if; 377 end if; 378 379 -- Change the actual affinity calling the operating system level 380 381 Set_Task_Affinity (T); 382 383 Unlock (T); 384 end Unchecked_Set_Affinity; 385 386end System.Multiprocessors.Dispatching_Domains; 387