Mercurial > hg > CbC > CbC_gcc
diff gcc/ada/libgnarl/s-mudido__affinity.adb @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gcc/ada/libgnarl/s-mudido__affinity.adb Fri Oct 27 22:46:09 2017 +0900 @@ -0,0 +1,401 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- SYSTEM.MULTIPROCESSORS.DISPATCHING_DOMAINS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011-2017, 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 -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- 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); + + 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.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); + + 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;