1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT RUN-TIME COMPONENTS                         --
4--                                                                          --
5--                SYSTEM.MULTIPROCESSORS.DISPATCHING_DOMAINS                --
6--                                                                          --
7--                                  B o d y                                 --
8--                                                                          --
9--          Copyright (C) 2011-2018, 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
35with System.Tasking.Initialization;
36with System.Task_Primitives.Operations; use System.Task_Primitives.Operations;
37
38with Ada.Unchecked_Conversion;
39
40package 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   begin
81      --  The exception Dispatching_Domain_Error is propagated if T is already
82      --  assigned to a Dispatching_Domain other than
83      --  System_Dispatching_Domain, or if CPU is not one of the processors of
84      --  Domain (and is not Not_A_Specific_CPU).
85
86      if Dispatching_Domain (Target.Common.Domain) /= System_Dispatching_Domain
87      then
88         raise Dispatching_Domain_Error with
89           "task already in user-defined dispatching domain";
90
91      elsif CPU /= Not_A_Specific_CPU and then CPU not in Domain'Range then
92         raise Dispatching_Domain_Error with
93           "processor does not belong to dispatching domain";
94      end if;
95
96      --  Assigning a task to System_Dispatching_Domain that is already
97      --  assigned to that domain has no effect.
98
99      if Domain = System_Dispatching_Domain then
100         return;
101
102      else
103         --  Set the task affinity once we know it is possible
104
105         Unchecked_Set_Affinity
106           (ST.Dispatching_Domain_Access (Domain), CPU, Target);
107      end if;
108   end Assign_Task;
109
110   ------------
111   -- Create --
112   ------------
113
114   function Create (First : CPU; Last : CPU_Range) return Dispatching_Domain is
115   begin
116      return Create ((First .. Last => True));
117   end Create;
118
119   function Create (Set : CPU_Set) return Dispatching_Domain is
120      ST_DD : aliased constant ST.Dispatching_Domain :=
121        ST.Dispatching_Domain (Set);
122      First : constant CPU       := Get_First_CPU (ST_DD'Unrestricted_Access);
123      Last  : constant CPU_Range := Get_Last_CPU (ST_DD'Unrestricted_Access);
124      subtype Rng is CPU_Range range First .. Last;
125
126      use type ST.Dispatching_Domain;
127      use type ST.Dispatching_Domain_Access;
128      use type ST.Task_Id;
129
130      T : ST.Task_Id;
131
132      New_System_Domain : ST.Dispatching_Domain := ST.System_Domain.all;
133
134      ST_DD_Slice : constant ST.Dispatching_Domain := ST_DD (Rng);
135
136   begin
137      --  The set of processors for creating a dispatching domain must
138      --  comply with the following restrictions:
139      --    - Not exceeding the range of available processors.
140      --    - CPUs from the System_Dispatching_Domain.
141      --    - The calling task must be the environment task.
142      --    - The call to Create must take place before the call to the main
143      --      subprogram.
144      --    - Set does not contain a processor with a task assigned to it.
145      --    - The allocation cannot leave System_Dispatching_Domain empty.
146
147      --  Note that a previous version of the language forbade empty domains.
148
149      if Rng'Last > Number_Of_CPUs then
150         raise Dispatching_Domain_Error with
151           "CPU not supported by the target";
152      end if;
153
154      declare
155         System_Domain_Slice : constant ST.Dispatching_Domain :=
156           ST.System_Domain (Rng);
157         Actual : constant ST.Dispatching_Domain :=
158           ST_DD_Slice and not System_Domain_Slice;
159         Expected : constant ST.Dispatching_Domain := (Rng => False);
160      begin
161         if Actual /= Expected then
162            raise Dispatching_Domain_Error with
163              "CPU not currently in System_Dispatching_Domain";
164         end if;
165      end;
166
167      if Self /= Environment_Task then
168         raise Dispatching_Domain_Error with
169           "only the environment task can create dispatching domains";
170      end if;
171
172      if ST.Dispatching_Domains_Frozen then
173         raise Dispatching_Domain_Error with
174           "cannot create dispatching domain after call to main procedure";
175      end if;
176
177      for Proc in Rng loop
178         if ST_DD (Proc) and then
179           ST.Dispatching_Domain_Tasks (Proc) /= 0
180         then
181            raise Dispatching_Domain_Error with "CPU has tasks assigned";
182         end if;
183      end loop;
184
185      New_System_Domain (Rng) := New_System_Domain (Rng) and not ST_DD_Slice;
186
187      if New_System_Domain = (New_System_Domain'Range => False) then
188         raise Dispatching_Domain_Error with
189           "would leave System_Dispatching_Domain empty";
190      end if;
191
192      return Result : constant Dispatching_Domain :=
193        new ST.Dispatching_Domain'(ST_DD_Slice)
194      do
195         --  At this point we need to fix the processors belonging to the
196         --  system domain, and change the affinity of every task that has
197         --  been created and assigned to the system domain.
198
199         ST.Initialization.Defer_Abort (Self);
200
201         Lock_RTS;
202
203         ST.System_Domain (Rng) := New_System_Domain (Rng);
204         pragma Assert (ST.System_Domain.all = New_System_Domain);
205
206         --  Iterate the list of tasks belonging to the default system
207         --  dispatching domain and set the appropriate affinity.
208
209         T := ST.All_Tasks_List;
210
211         while T /= null loop
212            if T.Common.Domain = ST.System_Domain then
213               Set_Task_Affinity (T);
214            end if;
215
216            T := T.Common.All_Tasks_Link;
217         end loop;
218
219         Unlock_RTS;
220
221         ST.Initialization.Undefer_Abort (Self);
222      end return;
223   end Create;
224
225   -----------------------------
226   -- Delay_Until_And_Set_CPU --
227   -----------------------------
228
229   procedure Delay_Until_And_Set_CPU
230     (Delay_Until_Time : Ada.Real_Time.Time;
231      CPU              : CPU_Range)
232   is
233   begin
234      --  Not supported atomically by the underlying operating systems.
235      --  Operating systems use to migrate the task immediately after the call
236      --  to set the affinity.
237
238      delay until Delay_Until_Time;
239      Set_CPU (CPU);
240   end Delay_Until_And_Set_CPU;
241
242   --------------------------------
243   -- Freeze_Dispatching_Domains --
244   --------------------------------
245
246   procedure Freeze_Dispatching_Domains is
247   begin
248      --  Signal the end of the elaboration code
249
250      ST.Dispatching_Domains_Frozen := True;
251   end Freeze_Dispatching_Domains;
252
253   -------------
254   -- Get_CPU --
255   -------------
256
257   function Get_CPU
258     (T : Ada.Task_Identification.Task_Id :=
259            Ada.Task_Identification.Current_Task) return CPU_Range
260   is
261   begin
262      return Convert_Ids (T).Common.Base_CPU;
263   end Get_CPU;
264
265   -----------------
266   -- Get_CPU_Set --
267   -----------------
268
269   function Get_CPU_Set (Domain : Dispatching_Domain) return CPU_Set is
270   begin
271      return CPU_Set (Domain.all);
272   end Get_CPU_Set;
273
274   ----------------------------
275   -- Get_Dispatching_Domain --
276   ----------------------------
277
278   function Get_Dispatching_Domain
279     (T : Ada.Task_Identification.Task_Id :=
280            Ada.Task_Identification.Current_Task) return Dispatching_Domain
281   is
282   begin
283      return Result : constant Dispatching_Domain :=
284        Dispatching_Domain (Convert_Ids (T).Common.Domain)
285      do
286         pragma Assert (Result /= null);
287      end return;
288   end Get_Dispatching_Domain;
289
290   -------------------
291   -- Get_First_CPU --
292   -------------------
293
294   function Get_First_CPU (Domain : Dispatching_Domain) return CPU is
295   begin
296      for Proc in Domain'Range loop
297         if Domain (Proc) then
298            return Proc;
299         end if;
300      end loop;
301
302      return CPU'First;
303   end Get_First_CPU;
304
305   ------------------
306   -- Get_Last_CPU --
307   ------------------
308
309   function Get_Last_CPU (Domain : Dispatching_Domain) return CPU_Range is
310   begin
311      for Proc in reverse Domain'Range loop
312         if Domain (Proc) then
313            return Proc;
314         end if;
315      end loop;
316
317      return CPU_Range'First;
318   end Get_Last_CPU;
319
320   -------------
321   -- Set_CPU --
322   -------------
323
324   procedure Set_CPU
325     (CPU : CPU_Range;
326      T   : Ada.Task_Identification.Task_Id :=
327              Ada.Task_Identification.Current_Task)
328   is
329      Target : constant ST.Task_Id := Convert_Ids (T);
330
331   begin
332      --  The exception Dispatching_Domain_Error is propagated if CPU is not
333      --  one of the processors of the Dispatching_Domain on which T is
334      --  assigned (and is not Not_A_Specific_CPU).
335
336      if CPU /= Not_A_Specific_CPU and then
337        (CPU not in Target.Common.Domain'Range or else
338         not Target.Common.Domain (CPU))
339      then
340         raise Dispatching_Domain_Error with
341           "processor does not belong to the task's dispatching domain";
342      end if;
343
344      Unchecked_Set_Affinity (Target.Common.Domain, CPU, Target);
345   end Set_CPU;
346
347   ----------------------------
348   -- Unchecked_Set_Affinity --
349   ----------------------------
350
351   procedure Unchecked_Set_Affinity
352     (Domain : ST.Dispatching_Domain_Access;
353      CPU    : CPU_Range;
354      T      : ST.Task_Id)
355   is
356      Source_CPU : constant CPU_Range := T.Common.Base_CPU;
357
358      use type ST.Dispatching_Domain_Access;
359
360   begin
361      Write_Lock (T);
362
363      --  Move to the new domain
364
365      T.Common.Domain := Domain;
366
367      --  Attach the CPU to the task
368
369      T.Common.Base_CPU := CPU;
370
371      --  Change the number of tasks attached to a given task in the system
372      --  domain if needed.
373
374      if not ST.Dispatching_Domains_Frozen
375        and then (Domain = null or else Domain = ST.System_Domain)
376      then
377         --  Reduce the number of tasks attached to the CPU from which this
378         --  task is being moved, if needed.
379
380         if Source_CPU /= Not_A_Specific_CPU then
381            ST.Dispatching_Domain_Tasks (Source_CPU) :=
382              ST.Dispatching_Domain_Tasks (Source_CPU) - 1;
383         end if;
384
385         --  Increase the number of tasks attached to the CPU to which this
386         --  task is being moved, if needed.
387
388         if CPU /= Not_A_Specific_CPU then
389            ST.Dispatching_Domain_Tasks (CPU) :=
390              ST.Dispatching_Domain_Tasks (CPU) + 1;
391         end if;
392      end if;
393
394      --  Change the actual affinity calling the operating system level
395
396      Set_Task_Affinity (T);
397
398      Unlock (T);
399   end Unchecked_Set_Affinity;
400
401end System.Multiprocessors.Dispatching_Domains;
402