------------------------------------------------------------------------------ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- -- SYSTEM.MULTIPROCESSORS.DISPATCHING_DOMAINS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ -- Body used on targets where the operating system supports setting task -- affinities. with System.Tasking.Initialization; with System.Task_Primitives.Operations; use System.Task_Primitives.Operations; with Ada.Unchecked_Conversion; package body System.Multiprocessors.Dispatching_Domains is package ST renames System.Tasking; ----------------------- -- Local subprograms -- ----------------------- function Convert_Ids is new Ada.Unchecked_Conversion (Ada.Task_Identification.Task_Id, ST.Task_Id); procedure Unchecked_Set_Affinity (Domain : ST.Dispatching_Domain_Access; CPU : CPU_Range; T : ST.Task_Id); -- Internal procedure to move a task to a target domain and CPU. No checks -- are performed about the validity of the domain and the CPU because they -- are done by the callers of this procedure (either Assign_Task or -- Set_CPU). procedure Freeze_Dispatching_Domains; pragma Export (Ada, Freeze_Dispatching_Domains, "__gnat_freeze_dispatching_domains"); -- Signal the time when no new dispatching domains can be created. It -- should be called before the environment task calls the main procedure -- (and after the elaboration code), so the binder-generated file needs to -- import and call this procedure. ----------------- -- Assign_Task -- ----------------- procedure Assign_Task (Domain : in out Dispatching_Domain; CPU : CPU_Range := Not_A_Specific_CPU; T : Ada.Task_Identification.Task_Id := Ada.Task_Identification.Current_Task) is Target : constant ST.Task_Id := Convert_Ids (T); use type ST.Dispatching_Domain_Access; begin -- The exception Dispatching_Domain_Error is propagated if T is already -- assigned to a Dispatching_Domain other than -- System_Dispatching_Domain, or if CPU is not one of the processors of -- Domain (and is not Not_A_Specific_CPU). if Dispatching_Domain (Target.Common.Domain) /= System_Dispatching_Domain then raise Dispatching_Domain_Error with "task already in user-defined dispatching domain"; elsif CPU /= Not_A_Specific_CPU and then CPU not in Domain'Range then raise Dispatching_Domain_Error with "processor does not belong to dispatching domain"; end if; -- Assigning a task to System_Dispatching_Domain that is already -- assigned to that domain has no effect. if Domain = System_Dispatching_Domain then return; else -- Set the task affinity once we know it is possible Unchecked_Set_Affinity (ST.Dispatching_Domain_Access (Domain), CPU, Target); end if; end Assign_Task; ------------ -- Create -- ------------ function Create (First : CPU; Last : CPU_Range) return Dispatching_Domain is begin return Create ((First .. Last => True)); end Create; function Create (Set : CPU_Set) return Dispatching_Domain is ST_DD : aliased constant ST.Dispatching_Domain := ST.Dispatching_Domain (Set); First : constant CPU := Get_First_CPU (ST_DD'Unrestricted_Access); Last : constant CPU_Range := Get_Last_CPU (ST_DD'Unrestricted_Access); subtype Rng is CPU_Range range First .. Last; use type ST.Dispatching_Domain; use type ST.Dispatching_Domain_Access; use type ST.Array_Allocated_Tasks; use type ST.Task_Id; T : ST.Task_Id; New_System_Domain : ST.Dispatching_Domain := ST.System_Domain.all; ST_DD_Slice : constant ST.Dispatching_Domain := ST_DD (Rng); begin -- The set of processors for creating a dispatching domain must -- comply with the following restrictions: -- - Not exceeding the range of available processors. -- - CPUs from the System_Dispatching_Domain. -- - The calling task must be the environment task. -- - The call to Create must take place before the call to the main -- subprogram. -- - Set does not contain a processor with a task assigned to it. -- - The allocation cannot leave System_Dispatching_Domain empty. -- Note that a previous version of the language forbade empty domains. if Rng'Last > Number_Of_CPUs then raise Dispatching_Domain_Error with "CPU not supported by the target"; end if; declare System_Domain_Slice : constant ST.Dispatching_Domain := ST.System_Domain (Rng); Actual : constant ST.Dispatching_Domain := ST_DD_Slice and not System_Domain_Slice; Expected : constant ST.Dispatching_Domain := (Rng => False); begin if Actual /= Expected then raise Dispatching_Domain_Error with "CPU not currently in System_Dispatching_Domain"; end if; end; if Self /= Environment_Task then raise Dispatching_Domain_Error with "only the environment task can create dispatching domains"; end if; if ST.Dispatching_Domains_Frozen then raise Dispatching_Domain_Error with "cannot create dispatching domain after call to main procedure"; end if; for Proc in Rng loop if ST_DD (Proc) and then ST.Dispatching_Domain_Tasks (Proc) /= 0 then raise Dispatching_Domain_Error with "CPU has tasks assigned"; end if; end loop; New_System_Domain (Rng) := New_System_Domain (Rng) and not ST_DD_Slice; if New_System_Domain = (New_System_Domain'Range => False) then raise Dispatching_Domain_Error with "would leave System_Dispatching_Domain empty"; end if; return Result : constant Dispatching_Domain := new ST.Dispatching_Domain'(ST_DD_Slice) do -- At this point we need to fix the processors belonging to the -- system domain, and change the affinity of every task that has -- been created and assigned to the system domain. ST.Initialization.Defer_Abort (Self); Lock_RTS; ST.System_Domain (Rng) := New_System_Domain (Rng); pragma Assert (ST.System_Domain.all = New_System_Domain); -- Iterate the list of tasks belonging to the default system -- dispatching domain and set the appropriate affinity. T := ST.All_Tasks_List; while T /= null loop if T.Common.Domain = ST.System_Domain then Set_Task_Affinity (T); end if; T := T.Common.All_Tasks_Link; end loop; Unlock_RTS; ST.Initialization.Undefer_Abort (Self); end return; end Create; ----------------------------- -- Delay_Until_And_Set_CPU -- ----------------------------- procedure Delay_Until_And_Set_CPU (Delay_Until_Time : Ada.Real_Time.Time; CPU : CPU_Range) is begin -- Not supported atomically by the underlying operating systems. -- Operating systems use to migrate the task immediately after the call -- to set the affinity. delay until Delay_Until_Time; Set_CPU (CPU); end Delay_Until_And_Set_CPU; -------------------------------- -- Freeze_Dispatching_Domains -- -------------------------------- procedure Freeze_Dispatching_Domains is begin -- Signal the end of the elaboration code ST.Dispatching_Domains_Frozen := True; end Freeze_Dispatching_Domains; ------------- -- Get_CPU -- ------------- function Get_CPU (T : Ada.Task_Identification.Task_Id := Ada.Task_Identification.Current_Task) return CPU_Range is begin return Convert_Ids (T).Common.Base_CPU; end Get_CPU; ----------------- -- Get_CPU_Set -- ----------------- function Get_CPU_Set (Domain : Dispatching_Domain) return CPU_Set is begin return CPU_Set (Domain.all); end Get_CPU_Set; ---------------------------- -- Get_Dispatching_Domain -- ---------------------------- function Get_Dispatching_Domain (T : Ada.Task_Identification.Task_Id := Ada.Task_Identification.Current_Task) return Dispatching_Domain is begin return Result : constant Dispatching_Domain := Dispatching_Domain (Convert_Ids (T).Common.Domain) do pragma Assert (Result /= null); end return; end Get_Dispatching_Domain; ------------------- -- Get_First_CPU -- ------------------- function Get_First_CPU (Domain : Dispatching_Domain) return CPU is begin for Proc in Domain'Range loop if Domain (Proc) then return Proc; end if; end loop; return CPU'First; end Get_First_CPU; ------------------ -- Get_Last_CPU -- ------------------ function Get_Last_CPU (Domain : Dispatching_Domain) return CPU_Range is begin for Proc in reverse Domain'Range loop if Domain (Proc) then return Proc; end if; end loop; return CPU_Range'First; end Get_Last_CPU; ------------- -- Set_CPU -- ------------- procedure Set_CPU (CPU : CPU_Range; T : Ada.Task_Identification.Task_Id := Ada.Task_Identification.Current_Task) is Target : constant ST.Task_Id := Convert_Ids (T); use type ST.Dispatching_Domain_Access; begin -- The exception Dispatching_Domain_Error is propagated if CPU is not -- one of the processors of the Dispatching_Domain on which T is -- assigned (and is not Not_A_Specific_CPU). if CPU /= Not_A_Specific_CPU and then (CPU not in Target.Common.Domain'Range or else not Target.Common.Domain (CPU)) then raise Dispatching_Domain_Error with "processor does not belong to the task's dispatching domain"; end if; Unchecked_Set_Affinity (Target.Common.Domain, CPU, Target); end Set_CPU; ---------------------------- -- Unchecked_Set_Affinity -- ---------------------------- procedure Unchecked_Set_Affinity (Domain : ST.Dispatching_Domain_Access; CPU : CPU_Range; T : ST.Task_Id) is Source_CPU : constant CPU_Range := T.Common.Base_CPU; use type ST.Dispatching_Domain_Access; begin Write_Lock (T); -- Move to the new domain T.Common.Domain := Domain; -- Attach the CPU to the task T.Common.Base_CPU := CPU; -- Change the number of tasks attached to a given task in the system -- domain if needed. if not ST.Dispatching_Domains_Frozen and then (Domain = null or else Domain = ST.System_Domain) then -- Reduce the number of tasks attached to the CPU from which this -- task is being moved, if needed. if Source_CPU /= Not_A_Specific_CPU then ST.Dispatching_Domain_Tasks (Source_CPU) := ST.Dispatching_Domain_Tasks (Source_CPU) - 1; end if; -- Increase the number of tasks attached to the CPU to which this -- task is being moved, if needed. if CPU /= Not_A_Specific_CPU then ST.Dispatching_Domain_Tasks (CPU) := ST.Dispatching_Domain_Tasks (CPU) + 1; end if; end if; -- Change the actual affinity calling the operating system level Set_Task_Affinity (T); Unlock (T); end Unchecked_Set_Affinity; end System.Multiprocessors.Dispatching_Domains;