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-2015, 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       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       First : constant CPU       := Get_First_CPU (ST_DD'Unrestricted_Access);
 125       Last  : constant CPU_Range := Get_Last_CPU (ST_DD'Unrestricted_Access);
 126       subtype Rng is CPU_Range range First .. Last;
 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       ST_DD_Slice : constant ST.Dispatching_Domain := ST_DD (Rng);
 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       end if;
 156
 157       declare
 158          System_Domain_Slice : constant ST.Dispatching_Domain :=
 159            ST.System_Domain (Rng);
 160          Actual : constant ST.Dispatching_Domain :=
 161            ST_DD_Slice and not System_Domain_Slice;
 162          Expected : constant ST.Dispatching_Domain := (Rng => False);
 163       begin
 164          if Actual /= Expected then
 165             raise Dispatching_Domain_Error with
 166               "CPU not currently in System_Dispatching_Domain";
 167          end if;
 168       end;
 169
 170       if Self /= Environment_Task then
 171          raise Dispatching_Domain_Error with
 172            "only the environment task can create dispatching domains";
 173       end if;
 174
 175       if ST.Dispatching_Domains_Frozen then
 176          raise Dispatching_Domain_Error with
 177            "cannot create dispatching domain after call to main procedure";
 178       end if;
 179
 180       for Proc in Rng loop
 181          if ST_DD (Proc) and then
 182            ST.Dispatching_Domain_Tasks (Proc) /= 0
 183          then
 184             raise Dispatching_Domain_Error with "CPU has tasks assigned";
 185          end if;
 186       end loop;
 187
 188       New_System_Domain (Rng) := New_System_Domain (Rng) and not ST_DD_Slice;
 189
 190       if New_System_Domain = (New_System_Domain'Range => False) then
 191          raise Dispatching_Domain_Error with
 192            "would leave System_Dispatching_Domain empty";
 193       end if;
 194
 195       return Result : constant Dispatching_Domain :=
 196         new ST.Dispatching_Domain'(ST_DD_Slice)
 197       do
 198          --  At this point we need to fix the processors belonging to the
 199          --  system domain, and change the affinity of every task that has
 200          --  been created and assigned to the system domain.
 201
 202          ST.Initialization.Defer_Abort (Self);
 203
 204          Lock_RTS;
 205
 206          ST.System_Domain (Rng) := New_System_Domain (Rng);
 207          pragma Assert (ST.System_Domain.all = New_System_Domain);
 208
 209          --  Iterate the list of tasks belonging to the default system
 210          --  dispatching domain and set the appropriate affinity.
 211
 212          T := ST.All_Tasks_List;
 213
 214          while T /= null loop
 215             if T.Common.Domain = ST.System_Domain then
 216                Set_Task_Affinity (T);
 217             end if;
 218
 219             T := T.Common.All_Tasks_Link;
 220          end loop;
 221
 222          Unlock_RTS;
 223
 224          ST.Initialization.Undefer_Abort (Self);
 225       end return;
 226    end Create;
 227
 228    -----------------------------
 229    -- Delay_Until_And_Set_CPU --
 230    -----------------------------
 231
 232    procedure Delay_Until_And_Set_CPU
 233      (Delay_Until_Time : Ada.Real_Time.Time;
 234       CPU              : CPU_Range)
 235    is
 236    begin
 237       --  Not supported atomically by the underlying operating systems.
 238       --  Operating systems use to migrate the task immediately after the call
 239       --  to set the affinity.
 240
 241       delay until Delay_Until_Time;
 242       Set_CPU (CPU);
 243    end Delay_Until_And_Set_CPU;
 244
 245    --------------------------------
 246    -- Freeze_Dispatching_Domains --
 247    --------------------------------
 248
 249    procedure Freeze_Dispatching_Domains is
 250    begin
 251       --  Signal the end of the elaboration code
 252
 253       ST.Dispatching_Domains_Frozen := True;
 254    end Freeze_Dispatching_Domains;
 255
 256    -------------
 257    -- Get_CPU --
 258    -------------
 259
 260    function Get_CPU
 261      (T : Ada.Task_Identification.Task_Id :=
 262             Ada.Task_Identification.Current_Task) return CPU_Range
 263    is
 264    begin
 265       return Convert_Ids (T).Common.Base_CPU;
 266    end Get_CPU;
 267
 268    -----------------
 269    -- Get_CPU_Set --
 270    -----------------
 271
 272    function Get_CPU_Set (Domain : Dispatching_Domain) return CPU_Set is
 273    begin
 274       return CPU_Set (Domain.all);
 275    end Get_CPU_Set;
 276
 277    ----------------------------
 278    -- Get_Dispatching_Domain --
 279    ----------------------------
 280
 281    function Get_Dispatching_Domain
 282      (T : Ada.Task_Identification.Task_Id :=
 283             Ada.Task_Identification.Current_Task) return Dispatching_Domain
 284    is
 285    begin
 286       return Result : constant Dispatching_Domain :=
 287         Dispatching_Domain (Convert_Ids (T).Common.Domain)
 288       do
 289          pragma Assert (Result /= null);
 290       end return;
 291    end Get_Dispatching_Domain;
 292
 293    -------------------
 294    -- Get_First_CPU --
 295    -------------------
 296
 297    function Get_First_CPU (Domain : Dispatching_Domain) return CPU is
 298    begin
 299       for Proc in Domain'Range loop
 300          if Domain (Proc) then
 301             return Proc;
 302          end if;
 303       end loop;
 304
 305       return CPU'First;
 306    end Get_First_CPU;
 307
 308    ------------------
 309    -- Get_Last_CPU --
 310    ------------------
 311
 312    function Get_Last_CPU (Domain : Dispatching_Domain) return CPU_Range is
 313    begin
 314       for Proc in reverse Domain'Range loop
 315          if Domain (Proc) then
 316             return Proc;
 317          end if;
 318       end loop;
 319
 320       return CPU_Range'First;
 321    end Get_Last_CPU;
 322
 323    -------------
 324    -- Set_CPU --
 325    -------------
 326
 327    procedure Set_CPU
 328      (CPU : CPU_Range;
 329       T   : Ada.Task_Identification.Task_Id :=
 330               Ada.Task_Identification.Current_Task)
 331    is
 332       Target : constant ST.Task_Id := Convert_Ids (T);
 333
 334       use type ST.Dispatching_Domain_Access;
 335
 336    begin
 337       --  The exception Dispatching_Domain_Error is propagated if CPU is not
 338       --  one of the processors of the Dispatching_Domain on which T is
 339       --  assigned (and is not Not_A_Specific_CPU).
 340
 341       if CPU /= Not_A_Specific_CPU and then
 342         (CPU not in Target.Common.Domain'Range or else
 343          not Target.Common.Domain (CPU))
 344       then
 345          raise Dispatching_Domain_Error with
 346            "processor does not belong to the task's dispatching domain";
 347       end if;
 348
 349       Unchecked_Set_Affinity (Target.Common.Domain, CPU, Target);
 350    end Set_CPU;
 351
 352    ----------------------------
 353    -- Unchecked_Set_Affinity --
 354    ----------------------------
 355
 356    procedure Unchecked_Set_Affinity
 357      (Domain : ST.Dispatching_Domain_Access;
 358       CPU    : CPU_Range;
 359       T      : ST.Task_Id)
 360    is
 361       Source_CPU : constant CPU_Range := T.Common.Base_CPU;
 362
 363       use type ST.Dispatching_Domain_Access;
 364
 365    begin
 366       Write_Lock (T);
 367
 368       --  Move to the new domain
 369
 370       T.Common.Domain := Domain;
 371
 372       --  Attach the CPU to the task
 373
 374       T.Common.Base_CPU := CPU;
 375
 376       --  Change the number of tasks attached to a given task in the system
 377       --  domain if needed.
 378
 379       if not ST.Dispatching_Domains_Frozen
 380         and then (Domain = null or else Domain = ST.System_Domain)
 381       then
 382          --  Reduce the number of tasks attached to the CPU from which this
 383          --  task is being moved, if needed.
 384
 385          if Source_CPU /= Not_A_Specific_CPU then
 386             ST.Dispatching_Domain_Tasks (Source_CPU) :=
 387               ST.Dispatching_Domain_Tasks (Source_CPU) - 1;
 388          end if;
 389
 390          --  Increase the number of tasks attached to the CPU to which this
 391          --  task is being moved, if needed.
 392
 393          if CPU /= Not_A_Specific_CPU then
 394             ST.Dispatching_Domain_Tasks (CPU) :=
 395               ST.Dispatching_Domain_Tasks (CPU) + 1;
 396          end if;
 397       end if;
 398
 399       --  Change the actual affinity calling the operating system level
 400
 401       Set_Task_Affinity (T);
 402
 403       Unlock (T);
 404    end Unchecked_Set_Affinity;
 405
 406 end System.Multiprocessors.Dispatching_Domains;