1------------------------------------------------------------------------------
2--                                                                          --
3--                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
4--                                                                          --
5--                        S Y S T E M . T A S K I N G                       --
6--                                                                          --
7--                                  B o d y                                 --
8--                                                                          --
9--          Copyright (C) 1992-2012, 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
32pragma Polling (Off);
33--  Turn off polling, we do not want ATC polling to take place during tasking
34--  operations. It causes infinite loops and other problems.
35
36with System.Task_Primitives.Operations;
37with System.Storage_Elements;
38
39package body System.Tasking is
40
41   package STPO renames System.Task_Primitives.Operations;
42
43   ---------------------
44   -- Detect_Blocking --
45   ---------------------
46
47   function Detect_Blocking return Boolean is
48      GL_Detect_Blocking : Integer;
49      pragma Import (C, GL_Detect_Blocking, "__gl_detect_blocking");
50      --  Global variable exported by the binder generated file. A value equal
51      --  to 1 indicates that pragma Detect_Blocking is active, while 0 is used
52      --  for the pragma not being present.
53
54   begin
55      return GL_Detect_Blocking = 1;
56   end Detect_Blocking;
57
58   -----------------------
59   -- Number_Of_Entries --
60   -----------------------
61
62   function Number_Of_Entries (Self_Id : Task_Id) return Entry_Index is
63   begin
64      return Entry_Index (Self_Id.Entry_Num);
65   end Number_Of_Entries;
66
67   ----------
68   -- Self --
69   ----------
70
71   function Self return Task_Id renames STPO.Self;
72
73   ------------------
74   -- Storage_Size --
75   ------------------
76
77   function Storage_Size (T : Task_Id) return System.Parameters.Size_Type is
78   begin
79      return
80         System.Parameters.Size_Type
81           (T.Common.Compiler_Data.Pri_Stack_Info.Size);
82   end Storage_Size;
83
84   ---------------------
85   -- Initialize_ATCB --
86   ---------------------
87
88   procedure Initialize_ATCB
89     (Self_ID          : Task_Id;
90      Task_Entry_Point : Task_Procedure_Access;
91      Task_Arg         : System.Address;
92      Parent           : Task_Id;
93      Elaborated       : Access_Boolean;
94      Base_Priority    : System.Any_Priority;
95      Base_CPU         : System.Multiprocessors.CPU_Range;
96      Domain           : Dispatching_Domain_Access;
97      Task_Info        : System.Task_Info.Task_Info_Type;
98      Stack_Size       : System.Parameters.Size_Type;
99      T                : Task_Id;
100      Success          : out Boolean)
101   is
102   begin
103      T.Common.State := Unactivated;
104
105      --  Initialize T.Common.LL
106
107      STPO.Initialize_TCB (T, Success);
108
109      if not Success then
110         return;
111      end if;
112
113      --  Wouldn't the following be better done using an assignment of an
114      --  aggregate so that we could be sure no components were forgotten???
115
116      T.Common.Parent                   := Parent;
117      T.Common.Base_Priority            := Base_Priority;
118      T.Common.Base_CPU                 := Base_CPU;
119      T.Common.Domain                   := Domain;
120      T.Common.Current_Priority         := 0;
121      T.Common.Protected_Action_Nesting := 0;
122      T.Common.Call                     := null;
123      T.Common.Task_Arg                 := Task_Arg;
124      T.Common.Task_Entry_Point         := Task_Entry_Point;
125      T.Common.Activator                := Self_ID;
126      T.Common.Wait_Count               := 0;
127      T.Common.Elaborated               := Elaborated;
128      T.Common.Activation_Failed        := False;
129      T.Common.Task_Info                := Task_Info;
130      T.Common.Global_Task_Lock_Nesting := 0;
131      T.Common.Fall_Back_Handler        := null;
132      T.Common.Specific_Handler         := null;
133      T.Common.Debug_Events             := (others => False);
134      T.Common.Task_Image_Len           := 0;
135
136      if T.Common.Parent = null then
137
138         --  For the environment task, the adjusted stack size is meaningless.
139         --  For example, an unspecified Stack_Size means that the stack size
140         --  is determined by the environment, or can grow dynamically. The
141         --  Stack_Checking algorithm therefore needs to use the requested
142         --  size, or 0 in case of an unknown size.
143
144         T.Common.Compiler_Data.Pri_Stack_Info.Size :=
145            Storage_Elements.Storage_Offset (Stack_Size);
146
147      else
148         T.Common.Compiler_Data.Pri_Stack_Info.Size :=
149           Storage_Elements.Storage_Offset
150             (Parameters.Adjust_Storage_Size (Stack_Size));
151      end if;
152
153      --  Link the task into the list of all tasks
154
155      T.Common.All_Tasks_Link := All_Tasks_List;
156      All_Tasks_List := T;
157   end Initialize_ATCB;
158
159   ----------------
160   -- Initialize --
161   ----------------
162
163   Main_Task_Image : constant String := "main_task";
164   --  Image of environment task
165
166   Main_Priority : Integer;
167   pragma Import (C, Main_Priority, "__gl_main_priority");
168   --  Priority for main task. Note that this is of type Integer, not Priority,
169   --  because we use the value -1 to indicate the default main priority, and
170   --  that is of course not in Priority'range.
171
172   Main_CPU : Integer;
173   pragma Import (C, Main_CPU, "__gl_main_cpu");
174   --  Affinity for main task. Note that this is of type Integer, not
175   --  CPU_Range, because we use the value -1 to indicate the unassigned
176   --  affinity, and that is of course not in CPU_Range'Range.
177
178   Initialized : Boolean := False;
179   --  Used to prevent multiple calls to Initialize
180
181   procedure Initialize is
182      T             : Task_Id;
183      Base_Priority : Any_Priority;
184      Base_CPU      : System.Multiprocessors.CPU_Range;
185      Success       : Boolean;
186
187      use type System.Multiprocessors.CPU_Range;
188
189   begin
190      if Initialized then
191         return;
192      end if;
193
194      Initialized := True;
195
196      --  Initialize Environment Task
197
198      Base_Priority :=
199        (if Main_Priority = Unspecified_Priority
200         then Default_Priority
201         else Priority (Main_Priority));
202
203      Base_CPU :=
204        (if Main_CPU = Unspecified_CPU
205         then System.Multiprocessors.Not_A_Specific_CPU
206         else System.Multiprocessors.CPU_Range (Main_CPU));
207
208      T := STPO.New_ATCB (0);
209      Initialize_ATCB
210        (null, null, Null_Address, Null_Task, null, Base_Priority, Base_CPU,
211         null, Task_Info.Unspecified_Task_Info, 0, T, Success);
212      pragma Assert (Success);
213
214      STPO.Initialize (T);
215      STPO.Set_Priority (T, T.Common.Base_Priority);
216      T.Common.State := Runnable;
217      T.Common.Task_Image_Len := Main_Task_Image'Length;
218      T.Common.Task_Image (Main_Task_Image'Range) := Main_Task_Image;
219
220      --  At program start-up the environment task is allocated to the default
221      --  system dispatching domain.
222      --  Make sure that the processors which are not available are not taken
223      --  into account. Use Number_Of_CPUs to know the exact number of
224      --  processors in the system at execution time.
225
226      System_Domain :=
227        new Dispatching_Domain'
228          (Multiprocessors.CPU'First .. Multiprocessors.Number_Of_CPUs =>
229             True);
230
231      T.Common.Domain := System_Domain;
232
233      Dispatching_Domain_Tasks :=
234        new Array_Allocated_Tasks'
235          (Multiprocessors.CPU'First .. Multiprocessors.Number_Of_CPUs => 0);
236
237      --  Signal that this task is being allocated to a processor
238
239      if Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU then
240
241         --  Increase the number of tasks attached to the CPU to which this
242         --  task is allocated.
243
244         Dispatching_Domain_Tasks (Base_CPU) :=
245           Dispatching_Domain_Tasks (Base_CPU) + 1;
246      end if;
247
248      --  Only initialize the first element since others are not relevant
249      --  in ravenscar mode. Rest of the initialization is done in Init_RTS.
250
251      T.Entry_Calls (1).Self := T;
252   end Initialize;
253
254   ---------------------
255   -- Set_Entry_Names --
256   ---------------------
257
258   procedure Set_Entry_Names
259     (Self_Id : Task_Id;
260      Names   : Task_Entry_Names_Access)
261   is
262   begin
263      Self_Id.Entry_Names := Names;
264   end Set_Entry_Names;
265
266end System.Tasking;
267