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 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 System.Tasking.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 Target.Common.Domain /= null and then
  89         Dispatching_Domain (Target.Common.Domain) /= System_Dispatching_Domain
  90       then
  91          raise Dispatching_Domain_Error with
  92            "task already in user-defined dispatching domain";
  93
  94       elsif CPU /= Not_A_Specific_CPU and then CPU not in Domain'Range then
  95          raise Dispatching_Domain_Error with
  96            "processor does not belong to dispatching domain";
  97       end if;
  98
  99       --  Assigning a task to System_Dispatching_Domain that is already
 100       --  assigned to that domain has no effect.
 101
 102       if Domain = System_Dispatching_Domain then
 103          return;
 104
 105       else
 106          --  Set the task affinity once we know it is possible
 107
 108          Unchecked_Set_Affinity
 109            (ST.Dispatching_Domain_Access (Domain), CPU, Target);
 110       end if;
 111    end Assign_Task;
 112
 113    ------------
 114    -- Create --
 115    ------------
 116
 117    function Create (First, Last : CPU) return Dispatching_Domain is
 118       use type System.Tasking.Dispatching_Domain;
 119       use type System.Tasking.Dispatching_Domain_Access;
 120       use type System.Tasking.Array_Allocated_Tasks;
 121       use type System.Tasking.Task_Id;
 122
 123       Valid_System_Domain : constant Boolean :=
 124         (First > CPU'First
 125           and then
 126             not (System_Dispatching_Domain (CPU'First .. First - 1) =
 127                                          (CPU'First .. First - 1 => False)))
 128                   or else (Last < Number_Of_CPUs
 129                             and then not
 130                               (System_Dispatching_Domain
 131                                 (Last + 1 .. Number_Of_CPUs) =
 132                                   (Last + 1 .. Number_Of_CPUs => False)));
 133       --  Constant that indicates whether there would exist a non-empty system
 134       --  dispatching domain after the creation of this dispatching domain.
 135
 136       T : ST.Task_Id;
 137
 138       New_Domain : Dispatching_Domain;
 139
 140    begin
 141       --  The range of processors for creating a dispatching domain must
 142       --  comply with the following restrictions:
 143       --    - Non-empty range
 144       --    - Not exceeding the range of available processors
 145       --    - Range from the System_Dispatching_Domain
 146       --    - Range does not contain a processor with a task assigned to it
 147       --    - The allocation cannot leave System_Dispatching_Domain empty
 148       --    - The calling task must be the environment task
 149       --    - The call to Create must take place before the call to the main
 150       --      subprogram
 151
 152       if First > Last then
 153          raise Dispatching_Domain_Error with "empty dispatching domain";
 154
 155       elsif Last > Number_Of_CPUs then
 156          raise Dispatching_Domain_Error with
 157            "CPU range not supported by the target";
 158
 159       elsif
 160         System_Dispatching_Domain (First .. Last) /= (First .. Last => True)
 161       then
 162          raise Dispatching_Domain_Error with
 163            "CPU range not currently in System_Dispatching_Domain";
 164
 165       elsif
 166         ST.Dispatching_Domain_Tasks (First .. Last) /= (First .. Last => 0)
 167       then
 168          raise Dispatching_Domain_Error with "CPU range has tasks assigned";
 169
 170       elsif not Valid_System_Domain then
 171          raise Dispatching_Domain_Error with
 172            "would leave System_Dispatching_Domain empty";
 173
 174       elsif Self /= Environment_Task then
 175          raise Dispatching_Domain_Error with
 176            "only the environment task can create dispatching domains";
 177
 178       elsif ST.Dispatching_Domains_Frozen then
 179          raise Dispatching_Domain_Error with
 180            "cannot create dispatching domain after call to main program";
 181       end if;
 182
 183       New_Domain := new ST.Dispatching_Domain'(First .. Last => True);
 184
 185       --  At this point we need to fix the processors belonging to the system
 186       --  domain, and change the affinity of every task that has been created
 187       --  and assigned to the system domain.
 188
 189       ST.Initialization.Defer_Abort (Self);
 190
 191       Lock_RTS;
 192
 193       System_Dispatching_Domain (First .. Last) := (First .. Last => False);
 194
 195       --  Iterate the list of tasks belonging to the default system
 196       --  dispatching domain and set the appropriate affinity.
 197
 198       T := ST.All_Tasks_List;
 199
 200       while T /= null loop
 201          if T.Common.Domain = null or else
 202            T.Common.Domain = ST.System_Domain
 203          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_Dispatching_Domain --
 259    ----------------------------
 260
 261    function Get_Dispatching_Domain
 262      (T : Ada.Task_Identification.Task_Id :=
 263             Ada.Task_Identification.Current_Task) return Dispatching_Domain
 264    is
 265    begin
 266       return Dispatching_Domain (Convert_Ids (T).Common.Domain);
 267    end Get_Dispatching_Domain;
 268
 269    -------------------
 270    -- Get_First_CPU --
 271    -------------------
 272
 273    function Get_First_CPU (Domain : Dispatching_Domain) return CPU is
 274    begin
 275       for Proc in Domain'Range loop
 276          if Domain (Proc) then
 277             return Proc;
 278          end if;
 279       end loop;
 280
 281       --  Should never reach the following return
 282
 283       return Domain'First;
 284    end Get_First_CPU;
 285
 286    ------------------
 287    -- Get_Last_CPU --
 288    ------------------
 289
 290    function Get_Last_CPU (Domain : Dispatching_Domain) return CPU is
 291    begin
 292       for Proc in reverse Domain'Range loop
 293          if Domain (Proc) then
 294             return Proc;
 295          end if;
 296       end loop;
 297
 298       --  Should never reach the following return
 299
 300       return Domain'Last;
 301    end Get_Last_CPU;
 302
 303    -------------
 304    -- Set_CPU --
 305    -------------
 306
 307    procedure Set_CPU
 308      (CPU : CPU_Range;
 309       T   : Ada.Task_Identification.Task_Id :=
 310               Ada.Task_Identification.Current_Task)
 311    is
 312       Target : constant ST.Task_Id := Convert_Ids (T);
 313
 314       use type ST.Dispatching_Domain_Access;
 315
 316    begin
 317       --  The exception Dispatching_Domain_Error is propagated if CPU is not
 318       --  one of the processors of the Dispatching_Domain on which T is
 319       --  assigned (and is not Not_A_Specific_CPU).
 320
 321       if CPU /= Not_A_Specific_CPU and then
 322         (CPU not in Target.Common.Domain'Range or else
 323          not Target.Common.Domain (CPU))
 324       then
 325          raise Dispatching_Domain_Error with
 326            "processor does not belong to the task's dispatching domain";
 327       end if;
 328
 329       Unchecked_Set_Affinity (Target.Common.Domain, CPU, Target);
 330    end Set_CPU;
 331
 332    ----------------------------
 333    -- Unchecked_Set_Affinity --
 334    ----------------------------
 335
 336    procedure Unchecked_Set_Affinity
 337      (Domain : ST.Dispatching_Domain_Access;
 338       CPU    : CPU_Range;
 339       T      : ST.Task_Id)
 340    is
 341       Source_CPU : constant CPU_Range := T.Common.Base_CPU;
 342
 343       use type System.Tasking.Dispatching_Domain_Access;
 344
 345    begin
 346       Write_Lock (T);
 347
 348       --  Move to the new domain
 349
 350       T.Common.Domain := Domain;
 351
 352       --  Attach the CPU to the task
 353
 354       T.Common.Base_CPU := CPU;
 355
 356       --  Change the number of tasks attached to a given task in the system
 357       --  domain if needed.
 358
 359       if not ST.Dispatching_Domains_Frozen
 360         and then (Domain = null or else Domain = ST.System_Domain)
 361       then
 362          --  Reduce the number of tasks attached to the CPU from which this
 363          --  task is being moved, if needed.
 364
 365          if Source_CPU /= Not_A_Specific_CPU then
 366             ST.Dispatching_Domain_Tasks (Source_CPU) :=
 367               ST.Dispatching_Domain_Tasks (Source_CPU) - 1;
 368          end if;
 369
 370          --  Increase the number of tasks attached to the CPU to which this
 371          --  task is being moved, if needed.
 372
 373          if CPU /= Not_A_Specific_CPU then
 374             ST.Dispatching_Domain_Tasks (CPU) :=
 375               ST.Dispatching_Domain_Tasks (CPU) + 1;
 376          end if;
 377       end if;
 378
 379       --  Change the actual affinity calling the operating system level
 380
 381       Set_Task_Affinity (T);
 382
 383       Unlock (T);
 384    end Unchecked_Set_Affinity;
 385
 386 end System.Multiprocessors.Dispatching_Domains;