gcc/ada/s-mudido-affinity.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                SYSTEM.MULTIPROCESSORS.DISPATCHING_DOMAINS                --
   6 --                                                                          --
   7 --                                  B o d y                                 --
   8 --                                                                          --
   9 --          Copyright (C) 2011-2017, 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
  35 with System.Tasking.Initialization;
  36 with System.Task_Primitives.Operations; use System.Task_Primitives.Operations;
  37
  38 with Ada.Unchecked_Conversion;
  39
  40 package 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
 401 end System.Multiprocessors.Dispatching_Domains;