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-2014, 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       subtype Rng is CPU_Range range
 125         Get_First_CPU (ST_DD'Unrestricted_Access) ..
 126         Get_Last_CPU (ST_DD'Unrestricted_Access);
 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       New_Domain : Dispatching_Domain;
 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
 156       elsif (ST_DD and not ST.System_Domain (Rng)) /= (Rng => False) then
 157          raise Dispatching_Domain_Error with
 158            "CPU not currently in System_Dispatching_Domain";
 159
 160       elsif Self /= Environment_Task then
 161          raise Dispatching_Domain_Error with
 162            "only the environment task can create dispatching domains";
 163
 164       elsif ST.Dispatching_Domains_Frozen then
 165          raise Dispatching_Domain_Error with
 166            "cannot create dispatching domain after call to main procedure";
 167       end if;
 168
 169       for Proc in Rng loop
 170          if ST_DD (Proc) and then
 171            ST.Dispatching_Domain_Tasks (Proc) /= 0
 172          then
 173             raise Dispatching_Domain_Error with "CPU has tasks assigned";
 174          end if;
 175       end loop;
 176
 177       New_System_Domain (Rng) := New_System_Domain (Rng) and not ST_DD;
 178
 179       if New_System_Domain = (New_System_Domain'Range => False) then
 180          raise Dispatching_Domain_Error with
 181            "would leave System_Dispatching_Domain empty";
 182       end if;
 183
 184       New_Domain := new ST.Dispatching_Domain'(ST_DD);
 185
 186       --  At this point we need to fix the processors belonging to the system
 187       --  domain, and change the affinity of every task that has been created
 188       --  and assigned to the system domain.
 189
 190       ST.Initialization.Defer_Abort (Self);
 191
 192       Lock_RTS;
 193
 194       ST.System_Domain (Rng) := New_System_Domain (Rng);
 195       pragma Assert (ST.System_Domain.all = New_System_Domain);
 196
 197       --  Iterate the list of tasks belonging to the default system
 198       --  dispatching domain and set the appropriate affinity.
 199
 200       T := ST.All_Tasks_List;
 201
 202       while T /= null loop
 203          if T.Common.Domain = ST.System_Domain 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_CPU_Set --
 259    -----------------
 260
 261    function Get_CPU_Set (Domain : Dispatching_Domain) return CPU_Set is
 262    begin
 263       return CPU_Set (Domain.all);
 264    end Get_CPU_Set;
 265
 266    ----------------------------
 267    -- Get_Dispatching_Domain --
 268    ----------------------------
 269
 270    function Get_Dispatching_Domain
 271      (T : Ada.Task_Identification.Task_Id :=
 272             Ada.Task_Identification.Current_Task) return Dispatching_Domain
 273    is
 274    begin
 275       return Result : constant Dispatching_Domain :=
 276         Dispatching_Domain (Convert_Ids (T).Common.Domain)
 277       do
 278          pragma Assert (Result /= null);
 279       end return;
 280    end Get_Dispatching_Domain;
 281
 282    -------------------
 283    -- Get_First_CPU --
 284    -------------------
 285
 286    function Get_First_CPU (Domain : Dispatching_Domain) return CPU is
 287    begin
 288       for Proc in Domain'Range loop
 289          if Domain (Proc) then
 290             return Proc;
 291          end if;
 292       end loop;
 293
 294       return CPU'First;
 295    end Get_First_CPU;
 296
 297    ------------------
 298    -- Get_Last_CPU --
 299    ------------------
 300
 301    function Get_Last_CPU (Domain : Dispatching_Domain) return CPU_Range is
 302    begin
 303       for Proc in reverse Domain'Range loop
 304          if Domain (Proc) then
 305             return Proc;
 306          end if;
 307       end loop;
 308
 309       return CPU_Range'First;
 310    end Get_Last_CPU;
 311
 312    -------------
 313    -- Set_CPU --
 314    -------------
 315
 316    procedure Set_CPU
 317      (CPU : CPU_Range;
 318       T   : Ada.Task_Identification.Task_Id :=
 319               Ada.Task_Identification.Current_Task)
 320    is
 321       Target : constant ST.Task_Id := Convert_Ids (T);
 322
 323       use type ST.Dispatching_Domain_Access;
 324
 325    begin
 326       --  The exception Dispatching_Domain_Error is propagated if CPU is not
 327       --  one of the processors of the Dispatching_Domain on which T is
 328       --  assigned (and is not Not_A_Specific_CPU).
 329
 330       if CPU /= Not_A_Specific_CPU and then
 331         (CPU not in Target.Common.Domain'Range or else
 332          not Target.Common.Domain (CPU))
 333       then
 334          raise Dispatching_Domain_Error with
 335            "processor does not belong to the task's dispatching domain";
 336       end if;
 337
 338       Unchecked_Set_Affinity (Target.Common.Domain, CPU, Target);
 339    end Set_CPU;
 340
 341    ----------------------------
 342    -- Unchecked_Set_Affinity --
 343    ----------------------------
 344
 345    procedure Unchecked_Set_Affinity
 346      (Domain : ST.Dispatching_Domain_Access;
 347       CPU    : CPU_Range;
 348       T      : ST.Task_Id)
 349    is
 350       Source_CPU : constant CPU_Range := T.Common.Base_CPU;
 351
 352       use type ST.Dispatching_Domain_Access;
 353
 354    begin
 355       Write_Lock (T);
 356
 357       --  Move to the new domain
 358
 359       T.Common.Domain := Domain;
 360
 361       --  Attach the CPU to the task
 362
 363       T.Common.Base_CPU := CPU;
 364
 365       --  Change the number of tasks attached to a given task in the system
 366       --  domain if needed.
 367
 368       if not ST.Dispatching_Domains_Frozen
 369         and then (Domain = null or else Domain = ST.System_Domain)
 370       then
 371          --  Reduce the number of tasks attached to the CPU from which this
 372          --  task is being moved, if needed.
 373
 374          if Source_CPU /= Not_A_Specific_CPU then
 375             ST.Dispatching_Domain_Tasks (Source_CPU) :=
 376               ST.Dispatching_Domain_Tasks (Source_CPU) - 1;
 377          end if;
 378
 379          --  Increase the number of tasks attached to the CPU to which this
 380          --  task is being moved, if needed.
 381
 382          if CPU /= Not_A_Specific_CPU then
 383             ST.Dispatching_Domain_Tasks (CPU) :=
 384               ST.Dispatching_Domain_Tasks (CPU) + 1;
 385          end if;
 386       end if;
 387
 388       --  Change the actual affinity calling the operating system level
 389
 390       Set_Task_Affinity (T);
 391
 392       Unlock (T);
 393    end Unchecked_Set_Affinity;
 394
 395 end System.Multiprocessors.Dispatching_Domains;