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