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, 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 data --
  46    ----------------
  47
  48    Dispatching_Domain_Tasks : array (CPU'First .. Number_Of_CPUs) of Natural :=
  49                                 (others => 0);
  50    --  We need to store whether there are tasks allocated to concrete
  51    --  processors in the default system dispatching domain because we need to
  52    --  check it before creating a new dispatching domain.
  53    --  ??? Tasks allocated with pragma CPU are not taken into account here.
  54
  55    Dispatching_Domains_Frozen : Boolean := False;
  56    --  True when the main procedure has been called. Hence, no new dispatching
  57    --  domains can be created when this flag is True.
  58
  59    -----------------------
  60    -- Local subprograms --
  61    -----------------------
  62
  63    function Convert_Ids is new
  64      Ada.Unchecked_Conversion (Ada.Task_Identification.Task_Id, ST.Task_Id);
  65
  66    procedure Unchecked_Set_Affinity
  67      (Domain : ST.Dispatching_Domain_Access;
  68       CPU    : CPU_Range;
  69       T      : ST.Task_Id);
  70    --  Internal procedure to move a task to a target domain and CPU. No checks
  71    --  are performed about the validity of the domain and the CPU because they
  72    --  are done by the callers of this procedure (either Assign_Task or
  73    --  Set_CPU).
  74
  75    procedure Freeze_Dispatching_Domains;
  76    pragma Export
  77      (Ada, Freeze_Dispatching_Domains, "__gnat_freeze_dispatching_domains");
  78    --  Signal the time when no new dispatching domains can be created. It
  79    --  should be called before the environment task calls the main procedure
  80    --  (and after the elaboration code), so the binder-generated file needs to
  81    --  import and call this procedure.
  82
  83    -----------------
  84    -- Assign_Task --
  85    -----------------
  86
  87    procedure Assign_Task
  88      (Domain : in out Dispatching_Domain;
  89       CPU    : CPU_Range := Not_A_Specific_CPU;
  90       T      : Ada.Task_Identification.Task_Id :=
  91                  Ada.Task_Identification.Current_Task)
  92    is
  93       Target : constant ST.Task_Id := Convert_Ids (T);
  94
  95       use type System.Tasking.Dispatching_Domain_Access;
  96
  97    begin
  98       --  The exception Dispatching_Domain_Error is propagated if T is already
  99       --  assigned to a Dispatching_Domain other than
 100       --  System_Dispatching_Domain, or if CPU is not one of the processors of
 101       --  Domain (and is not Not_A_Specific_CPU).
 102
 103       if Target.Common.Domain /= null and then
 104         Dispatching_Domain (Target.Common.Domain) /= System_Dispatching_Domain
 105       then
 106          raise Dispatching_Domain_Error with
 107            "task already in user-defined dispatching domain";
 108
 109       elsif CPU /= Not_A_Specific_CPU and then CPU not in Domain'Range then
 110          raise Dispatching_Domain_Error with
 111            "processor does not belong to dispatching domain";
 112       end if;
 113
 114       --  Assigning a task to System_Dispatching_Domain that is already
 115       --  assigned to that domain has no effect.
 116
 117       if Domain = System_Dispatching_Domain then
 118          return;
 119
 120       else
 121          --  Set the task affinity once we know it is possible
 122
 123          Unchecked_Set_Affinity
 124            (ST.Dispatching_Domain_Access (Domain), CPU, Target);
 125       end if;
 126    end Assign_Task;
 127
 128    ------------
 129    -- Create --
 130    ------------
 131
 132    function Create (First, Last : CPU) return Dispatching_Domain is
 133       use type System.Tasking.Dispatching_Domain;
 134       use type System.Tasking.Dispatching_Domain_Access;
 135       use type System.Tasking.Task_Id;
 136
 137       Valid_System_Domain : constant Boolean :=
 138         (First > CPU'First
 139           and then
 140             not (System_Dispatching_Domain (CPU'First .. First - 1) =
 141                                          (CPU'First .. First - 1 => False)))
 142                   or else (Last < Number_Of_CPUs
 143                             and then not
 144                               (System_Dispatching_Domain
 145                                 (Last + 1 .. Number_Of_CPUs) =
 146                                   (Last + 1 .. Number_Of_CPUs => False)));
 147       --  Constant that indicates whether there would exist a non-empty system
 148       --  dispatching domain after the creation of this dispatching domain.
 149
 150       T : ST.Task_Id;
 151
 152       New_Domain : Dispatching_Domain;
 153
 154    begin
 155       --  The range of processors for creating a dispatching domain must
 156       --  comply with the following restrictions:
 157       --    - Non-empty range
 158       --    - Not exceeding the range of available processors
 159       --    - Range from the System_Dispatching_Domain
 160       --    - Range does not contain a processor with a task assigned to it
 161       --    - The allocation cannot leave System_Dispatching_Domain empty
 162       --    - The calling task must be the environment task
 163       --    - The call to Create must take place before the call to the main
 164       --      subprogram
 165
 166       if First > Last then
 167          raise Dispatching_Domain_Error with "empty dispatching domain";
 168
 169       elsif Last > Number_Of_CPUs then
 170          raise Dispatching_Domain_Error with
 171            "CPU range not supported by the target";
 172
 173       elsif
 174         System_Dispatching_Domain (First .. Last) /= (First .. Last => True)
 175       then
 176          raise Dispatching_Domain_Error with
 177            "CPU range not currently in System_Dispatching_Domain";
 178
 179       elsif
 180         Dispatching_Domain_Tasks (First .. Last) /= (First .. Last => 0)
 181       then
 182          raise Dispatching_Domain_Error with "CPU range has tasks assigned";
 183
 184       elsif not Valid_System_Domain then
 185          raise Dispatching_Domain_Error with
 186            "would leave System_Dispatching_Domain empty";
 187
 188       elsif Self /= Environment_Task then
 189          raise Dispatching_Domain_Error with
 190            "only the environment task can create dispatching domains";
 191
 192       elsif Dispatching_Domains_Frozen then
 193          raise Dispatching_Domain_Error with
 194            "cannot create dispatching domain after call to main program";
 195       end if;
 196
 197       New_Domain := new ST.Dispatching_Domain'(First .. Last => True);
 198
 199       --  At this point we need to fix the processors belonging to the system
 200       --  domain, and change the affinity of every task that has been created
 201       --  and assigned to the system domain.
 202
 203       ST.Initialization.Defer_Abort (Self);
 204
 205       Lock_RTS;
 206
 207       System_Dispatching_Domain (First .. Last) := (First .. Last => False);
 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 = null or else
 216            T.Common.Domain = ST.System_Domain
 217          then
 218             Set_Task_Affinity (T);
 219          end if;
 220
 221          T := T.Common.All_Tasks_Link;
 222       end loop;
 223
 224       Unlock_RTS;
 225
 226       ST.Initialization.Undefer_Abort (Self);
 227
 228       return New_Domain;
 229    end Create;
 230
 231    -----------------------------
 232    -- Delay_Until_And_Set_CPU --
 233    -----------------------------
 234
 235    procedure Delay_Until_And_Set_CPU
 236      (Delay_Until_Time : Ada.Real_Time.Time;
 237       CPU              : CPU_Range)
 238    is
 239    begin
 240       --  Not supported atomically by the underlying operating systems.
 241       --  Operating systems use to migrate the task immediately after the call
 242       --  to set the affinity.
 243
 244       delay until Delay_Until_Time;
 245       Set_CPU (CPU);
 246    end Delay_Until_And_Set_CPU;
 247
 248    --------------------------------
 249    -- Freeze_Dispatching_Domains --
 250    --------------------------------
 251
 252    procedure Freeze_Dispatching_Domains is
 253    begin
 254       --  Signal the end of the elaboration code
 255
 256       Dispatching_Domains_Frozen := True;
 257    end Freeze_Dispatching_Domains;
 258
 259    -------------
 260    -- Get_CPU --
 261    -------------
 262
 263    function Get_CPU
 264      (T : Ada.Task_Identification.Task_Id :=
 265             Ada.Task_Identification.Current_Task) return CPU_Range
 266    is
 267    begin
 268       return Convert_Ids (T).Common.Base_CPU;
 269    end Get_CPU;
 270
 271    ----------------------------
 272    -- Get_Dispatching_Domain --
 273    ----------------------------
 274
 275    function Get_Dispatching_Domain
 276      (T : Ada.Task_Identification.Task_Id :=
 277             Ada.Task_Identification.Current_Task) return Dispatching_Domain
 278    is
 279    begin
 280       return Dispatching_Domain (Convert_Ids (T).Common.Domain);
 281    end Get_Dispatching_Domain;
 282
 283    -------------------
 284    -- Get_First_CPU --
 285    -------------------
 286
 287    function Get_First_CPU (Domain : Dispatching_Domain) return CPU is
 288    begin
 289       for Proc in Domain'Range loop
 290          if Domain (Proc) then
 291             return Proc;
 292          end if;
 293       end loop;
 294
 295       --  Should never reach the following return
 296
 297       return Domain'First;
 298    end Get_First_CPU;
 299
 300    ------------------
 301    -- Get_Last_CPU --
 302    ------------------
 303
 304    function Get_Last_CPU (Domain : Dispatching_Domain) return CPU is
 305    begin
 306       for Proc in reverse Domain'Range loop
 307          if Domain (Proc) then
 308             return Proc;
 309          end if;
 310       end loop;
 311
 312       --  Should never reach the following return
 313
 314       return Domain'Last;
 315    end Get_Last_CPU;
 316
 317    -------------
 318    -- Set_CPU --
 319    -------------
 320
 321    procedure Set_CPU
 322      (CPU : CPU_Range;
 323       T   : Ada.Task_Identification.Task_Id :=
 324               Ada.Task_Identification.Current_Task)
 325    is
 326       Target : constant ST.Task_Id := Convert_Ids (T);
 327
 328       use type ST.Dispatching_Domain_Access;
 329
 330    begin
 331       --  The exception Dispatching_Domain_Error is propagated if CPU is not
 332       --  one of the processors of the Dispatching_Domain on which T is
 333       --  assigned (and is not Not_A_Specific_CPU).
 334
 335       if CPU /= Not_A_Specific_CPU and then
 336         (CPU not in Target.Common.Domain'Range or else
 337          not Target.Common.Domain (CPU))
 338       then
 339          raise Dispatching_Domain_Error with
 340            "CPU does not belong to the task's dispatching domain";
 341       end if;
 342
 343       Unchecked_Set_Affinity (Target.Common.Domain, CPU, Target);
 344    end Set_CPU;
 345
 346    ----------------------------
 347    -- Unchecked_Set_Affinity --
 348    ----------------------------
 349
 350    procedure Unchecked_Set_Affinity
 351      (Domain : ST.Dispatching_Domain_Access;
 352       CPU    : CPU_Range;
 353       T      : ST.Task_Id)
 354    is
 355       Source_CPU : constant CPU_Range := T.Common.Base_CPU;
 356
 357       use type System.Tasking.Dispatching_Domain_Access;
 358
 359    begin
 360       Write_Lock (T);
 361
 362       --  Move to the new domain
 363
 364       T.Common.Domain := Domain;
 365
 366       --  Attach the CPU to the task
 367
 368       T.Common.Base_CPU := CPU;
 369
 370       --  Change the number of tasks attached to a given task in the system
 371       --  domain if needed.
 372
 373       if not Dispatching_Domains_Frozen
 374         and then (Domain = null or else Domain = ST.System_Domain)
 375       then
 376          --  Reduce the number of tasks attached to the CPU from which this
 377          --  task is being moved, if needed.
 378
 379          if Source_CPU /= Not_A_Specific_CPU then
 380             Dispatching_Domain_Tasks (Source_CPU) :=
 381               Dispatching_Domain_Tasks (Source_CPU) - 1;
 382          end if;
 383
 384          --  Increase the number of tasks attached to the CPU to which this
 385          --  task is being moved, if needed.
 386
 387          if CPU /= Not_A_Specific_CPU then
 388             Dispatching_Domain_Tasks (CPU) :=
 389               Dispatching_Domain_Tasks (CPU) + 1;
 390          end if;
 391       end if;
 392
 393       --  Change the actual affinity calling the operating system level
 394
 395       Set_Task_Affinity (T);
 396
 397       Unlock (T);
 398    end Unchecked_Set_Affinity;
 399
 400 end System.Multiprocessors.Dispatching_Domains;