1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                    S Y S T E M . S O F T _ L I N K S                     --
6--                                                                          --
7--                                 S p e c                                  --
8--                                                                          --
9--          Copyright (C) 1992-2018, Free Software Foundation, Inc.         --
10--                                                                          --
11-- GNAT 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-- GNAT was originally developed  by the GNAT team at  New York University. --
28-- Extensive contributions were provided by Ada Core Technologies Inc.      --
29--                                                                          --
30------------------------------------------------------------------------------
31
32--  This package contains a set of subprogram access variables that access
33--  some low-level primitives that are different depending whether tasking is
34--  involved or not (e.g. the Get/Set_Jmpbuf_Address that needs to provide a
35--  different value for each task). To avoid dragging in the tasking runtimes
36--  all the time, we use a system of soft links where the links are
37--  initialized to non-tasking versions, and then if the tasking support is
38--  initialized, they are set to the real tasking versions.
39
40pragma Compiler_Unit_Warning;
41
42with Ada.Exceptions;
43with System.Parameters;
44with System.Secondary_Stack;
45with System.Stack_Checking;
46
47package System.Soft_Links is
48   pragma Preelaborate;
49
50   package SST renames System.Secondary_Stack;
51
52   subtype EOA is Ada.Exceptions.Exception_Occurrence_Access;
53   subtype EO is Ada.Exceptions.Exception_Occurrence;
54
55   function Current_Target_Exception return EO;
56   pragma Import
57     (Ada, Current_Target_Exception, "__gnat_current_target_exception");
58   --  Import this subprogram from the private part of Ada.Exceptions
59
60   --  First we have the access subprogram types used to establish the links.
61   --  The approach is to establish variables containing access subprogram
62   --  values, which by default point to dummy no tasking versions of routines.
63
64   type No_Param_Proc     is access procedure;
65   pragma Favor_Top_Level (No_Param_Proc);
66   pragma Suppress_Initialization (No_Param_Proc);
67   --  Some uninitialized objects of that type are initialized by the Binder
68   --  so it is important that such objects are not reset to null during
69   --  elaboration.
70
71   type Addr_Param_Proc   is access procedure (Addr : Address);
72   pragma Favor_Top_Level (Addr_Param_Proc);
73   type EO_Param_Proc     is access procedure (Excep : EO);
74   pragma Favor_Top_Level (EO_Param_Proc);
75
76   type Get_Address_Call  is access function return Address;
77   pragma Favor_Top_Level (Get_Address_Call);
78   type Set_Address_Call  is access procedure (Addr : Address);
79   pragma Favor_Top_Level (Set_Address_Call);
80   type Set_Address_Call2 is access procedure
81     (Self_ID : Address; Addr : Address);
82   pragma Favor_Top_Level (Set_Address_Call2);
83
84   type Get_Integer_Call  is access function return Integer;
85   pragma Favor_Top_Level (Get_Integer_Call);
86   type Set_Integer_Call  is access procedure (Len : Integer);
87   pragma Favor_Top_Level (Set_Integer_Call);
88
89   type Get_EOA_Call      is access function return EOA;
90   pragma Favor_Top_Level (Get_EOA_Call);
91   type Set_EOA_Call      is access procedure (Excep : EOA);
92   pragma Favor_Top_Level (Set_EOA_Call);
93   type Set_EO_Call       is access procedure (Excep : EO);
94   pragma Favor_Top_Level (Set_EO_Call);
95
96   type Get_Stack_Call    is access function return SST.SS_Stack_Ptr;
97   pragma Favor_Top_Level (Get_Stack_Call);
98   type Set_Stack_Call    is access procedure (Stack : SST.SS_Stack_Ptr);
99   pragma Favor_Top_Level (Set_Stack_Call);
100
101   type Special_EO_Call   is access
102     procedure (Excep : EO := Current_Target_Exception);
103   pragma Favor_Top_Level (Special_EO_Call);
104
105   type Timed_Delay_Call  is access
106     procedure (Time : Duration; Mode : Integer);
107   pragma Favor_Top_Level (Timed_Delay_Call);
108
109   type Get_Stack_Access_Call is access
110     function return Stack_Checking.Stack_Access;
111   pragma Favor_Top_Level (Get_Stack_Access_Call);
112
113   type Task_Name_Call is access
114     function return String;
115   pragma Favor_Top_Level (Task_Name_Call);
116
117   --  Suppress checks on all these types, since we know the corresponding
118   --  values can never be null (the soft links are always initialized).
119
120   pragma Suppress (Access_Check, No_Param_Proc);
121   pragma Suppress (Access_Check, Addr_Param_Proc);
122   pragma Suppress (Access_Check, EO_Param_Proc);
123   pragma Suppress (Access_Check, Get_Address_Call);
124   pragma Suppress (Access_Check, Set_Address_Call);
125   pragma Suppress (Access_Check, Set_Address_Call2);
126   pragma Suppress (Access_Check, Get_Integer_Call);
127   pragma Suppress (Access_Check, Set_Integer_Call);
128   pragma Suppress (Access_Check, Get_EOA_Call);
129   pragma Suppress (Access_Check, Set_EOA_Call);
130   pragma Suppress (Access_Check, Get_Stack_Call);
131   pragma Suppress (Access_Check, Set_Stack_Call);
132   pragma Suppress (Access_Check, Timed_Delay_Call);
133   pragma Suppress (Access_Check, Get_Stack_Access_Call);
134   pragma Suppress (Access_Check, Task_Name_Call);
135
136   --  The following one is not related to tasking/no-tasking but to the
137   --  traceback decorators for exceptions.
138
139   type Traceback_Decorator_Wrapper_Call is access
140     function (Traceback : System.Address;
141               Len       : Natural)
142               return      String;
143   pragma Favor_Top_Level (Traceback_Decorator_Wrapper_Call);
144
145   --  Declarations for the no tasking versions of the required routines
146
147   procedure Abort_Defer_NT;
148   --  Defer task abort (non-tasking case, does nothing)
149
150   procedure Abort_Undefer_NT;
151   --  Undefer task abort (non-tasking case, does nothing)
152
153   procedure Abort_Handler_NT;
154   --  Handle task abort (non-tasking case, does nothing). Currently, no port
155   --  makes use of this, but we retain the interface for possible future use.
156
157   function Check_Abort_Status_NT return Integer;
158   --  Returns Boolean'Pos (True) iff abort signal should raise
159   --  Standard'Abort_Signal.
160
161   procedure Task_Lock_NT;
162   --  Lock out other tasks (non-tasking case, does nothing)
163
164   procedure Task_Unlock_NT;
165   --  Release lock set by Task_Lock (non-tasking case, does nothing)
166
167   procedure Task_Termination_NT (Excep : EO);
168   --  Handle task termination routines for the environment task (non-tasking
169   --  case, does nothing).
170
171   procedure Adafinal_NT;
172   --  Shuts down the runtime system (non-tasking case)
173
174   Abort_Defer : No_Param_Proc := Abort_Defer_NT'Access;
175   pragma Suppress (Access_Check, Abort_Defer);
176   --  Defer task abort (task/non-task case as appropriate)
177
178   Abort_Undefer : No_Param_Proc := Abort_Undefer_NT'Access;
179   pragma Suppress (Access_Check, Abort_Undefer);
180   --  Undefer task abort (task/non-task case as appropriate)
181
182   Abort_Handler : No_Param_Proc := Abort_Handler_NT'Access;
183   --  Handle task abort (task/non-task case as appropriate)
184
185   Check_Abort_Status : Get_Integer_Call := Check_Abort_Status_NT'Access;
186   --  Called when Abort_Signal is delivered to the process.  Checks to
187   --  see if signal should result in raising Standard'Abort_Signal.
188
189   Lock_Task : No_Param_Proc := Task_Lock_NT'Access;
190   --  Locks out other tasks. Preceding a section of code by Task_Lock and
191   --  following it by Task_Unlock creates a critical region. This is used
192   --  for ensuring that a region of non-tasking code (such as code used to
193   --  allocate memory) is tasking safe. Note that it is valid for calls to
194   --  Task_Lock/Task_Unlock to be nested, and this must work properly, i.e.
195   --  only the corresponding outer level Task_Unlock will actually unlock.
196   --  This routine also prevents against asynchronous aborts (abort is
197   --  deferred).
198
199   Unlock_Task : No_Param_Proc := Task_Unlock_NT'Access;
200   --  Releases lock previously set by call to Lock_Task. In the nested case,
201   --  all nested locks must be released before other tasks competing for the
202   --  tasking lock are released.
203   --
204   --  In the non nested case, this routine terminates the protection against
205   --  asynchronous aborts introduced by Lock_Task (unless abort was already
206   --  deferred before the call to Lock_Task (e.g in a protected procedures).
207   --
208   --  Note: the recommended protocol for using Lock_Task and Unlock_Task
209   --  is as follows:
210   --
211   --    Locked_Processing : begin
212   --       System.Soft_Links.Lock_Task.all;
213   --       ...
214   --       System.Soft_Links.Unlock_Task.all;
215   --
216   --    exception
217   --       when others =>
218   --          System.Soft_Links.Unlock_Task.all;
219   --          raise;
220   --    end Locked_Processing;
221   --
222   --  This ensures that the lock is not left set if an exception is raised
223   --  explicitly or implicitly during the critical locked region.
224
225   Task_Termination_Handler : EO_Param_Proc := Task_Termination_NT'Access;
226   --  Handle task termination routines (task/non-task case as appropriate)
227
228   Finalize_Library_Objects : No_Param_Proc;
229   pragma Export (C, Finalize_Library_Objects,
230                  "__gnat_finalize_library_objects");
231   --  Will be initialized by the binder
232
233   Adafinal : No_Param_Proc := Adafinal_NT'Access;
234   --  Performs the finalization of the Ada Runtime
235
236   function  Get_Jmpbuf_Address_NT return  Address;
237   procedure Set_Jmpbuf_Address_NT (Addr : Address);
238
239   Get_Jmpbuf_Address : Get_Address_Call := Get_Jmpbuf_Address_NT'Access;
240   Set_Jmpbuf_Address : Set_Address_Call := Set_Jmpbuf_Address_NT'Access;
241
242   function  Get_Sec_Stack_NT return  SST.SS_Stack_Ptr;
243   procedure Set_Sec_Stack_NT (Stack : SST.SS_Stack_Ptr);
244
245   Get_Sec_Stack : Get_Stack_Call := Get_Sec_Stack_NT'Access;
246   Set_Sec_Stack : Set_Stack_Call := Set_Sec_Stack_NT'Access;
247
248   function Get_Current_Excep_NT return EOA;
249
250   Get_Current_Excep : Get_EOA_Call := Get_Current_Excep_NT'Access;
251
252   function Get_Stack_Info_NT return Stack_Checking.Stack_Access;
253
254   Get_Stack_Info : Get_Stack_Access_Call := Get_Stack_Info_NT'Access;
255
256   --------------------------
257   -- Master_Id Soft-Links --
258   --------------------------
259
260   --  Soft-Links are used for procedures that manipulate Master_Ids because
261   --  a Master_Id must be generated for access to limited class-wide types,
262   --  whose root may be extended with task components.
263
264   function Current_Master_NT return Integer;
265   procedure Enter_Master_NT;
266   procedure Complete_Master_NT;
267
268   Current_Master  : Get_Integer_Call := Current_Master_NT'Access;
269   Enter_Master    : No_Param_Proc    := Enter_Master_NT'Access;
270   Complete_Master : No_Param_Proc    := Complete_Master_NT'Access;
271
272   ----------------------
273   -- Delay Soft-Links --
274   ----------------------
275
276   --  Soft-Links are used for procedures that manipulate time to avoid
277   --  dragging the tasking run time when using delay statements.
278
279   Timed_Delay : Timed_Delay_Call;
280
281   --------------------------
282   -- Task Name Soft-Links --
283   --------------------------
284
285   function Task_Name_NT return String;
286
287   Task_Name : Task_Name_Call := Task_Name_NT'Access;
288
289   -------------------------------------
290   -- Exception Tracebacks Soft-Links --
291   -------------------------------------
292
293   Library_Exception : EO;
294   --  Library-level finalization routines use this common reference to store
295   --  the first library-level exception which occurs during finalization.
296
297   Library_Exception_Set : Boolean := False;
298   --  Used in conjunction with Library_Exception, set when an exception has
299   --  been stored.
300
301   Traceback_Decorator_Wrapper : Traceback_Decorator_Wrapper_Call;
302   --  Wrapper to the possible user specified traceback decorator to be
303   --  called during automatic output of exception data.
304
305   --  The null value of this wrapper correspond sto the null value of the
306   --  current actual decorator. This is ensured first by the null initial
307   --  value of the corresponding variables, and then by Set_Trace_Decorator
308   --  in g-exctra.adb.
309
310   pragma Atomic (Traceback_Decorator_Wrapper);
311   --  Since concurrent read/write operations may occur on this variable.
312   --  See the body of Tailored_Exception_Traceback in Ada.Exceptions for
313   --  a more detailed description of the potential problems.
314
315   procedure Save_Library_Occurrence (E : EOA);
316   --  When invoked, this routine saves an exception occurrence into a hidden
317   --  reference. Subsequent calls will have no effect.
318
319   ------------------------
320   -- Task Specific Data --
321   ------------------------
322
323   --  Here we define a single type that encapsulates the various task
324   --  specific data. This type is used to store the necessary data into the
325   --  Task_Control_Block or into a global variable in the non tasking case.
326
327   type TSD is record
328      Pri_Stack_Info : aliased Stack_Checking.Stack_Info;
329      --  Information on stack (Base/Limit/Size) used by System.Stack_Checking.
330      --  If this TSD does not belong to the environment task, the Size field
331      --  must be initialized to the tasks requested stack size before the task
332      --  can do its first stack check.
333
334      Jmpbuf_Address : System.Address;
335      --  Address of jump buffer used to store the address of the current
336      --  longjmp/setjmp buffer for exception management. These buffers are
337      --  threaded into a stack, and the address here is the top of the stack.
338      --  A null address means that no exception handler is currently active.
339
340      Sec_Stack_Ptr : SST.SS_Stack_Ptr;
341      --  Pointer of the allocated secondary stack
342
343      Current_Excep : aliased EO;
344      --  Exception occurrence that contains the information for the current
345      --  exception. Note that any exception in the same task destroys this
346      --  information, so the data in this variable must be copied out before
347      --  another exception can occur.
348      --
349      --  Also act as a list of the active exceptions in the case of the GCC
350      --  exception mechanism, organized as a stack with the most recent first.
351   end record;
352
353   procedure Create_TSD
354     (New_TSD        : in out TSD;
355      Sec_Stack      : SST.SS_Stack_Ptr;
356      Sec_Stack_Size : System.Parameters.Size_Type);
357   pragma Inline (Create_TSD);
358   --  Called from s-tassta when a new thread is created to perform
359   --  any required initialization of the TSD.
360
361   procedure Destroy_TSD (Old_TSD : in out TSD);
362   pragma Inline (Destroy_TSD);
363   --  Called from s-tassta just before a thread is destroyed to perform
364   --  any required finalization.
365
366   function Get_GNAT_Exception return Ada.Exceptions.Exception_Id;
367   pragma Inline (Get_GNAT_Exception);
368   --  This function obtains the Exception_Id from the Exception_Occurrence
369   --  referenced by the Current_Excep field of the task specific data, i.e.
370   --  the call is equivalent to
371   --  Exception_Identity (Get_Current_Exception.all)
372
373   --  Export the Get/Set routines for the various Task Specific Data (TSD)
374   --  elements as callable subprograms instead of objects of access to
375   --  subprogram types.
376
377   function  Get_Jmpbuf_Address_Soft return  Address;
378   procedure Set_Jmpbuf_Address_Soft (Addr : Address);
379   pragma Inline (Get_Jmpbuf_Address_Soft);
380   pragma Inline (Set_Jmpbuf_Address_Soft);
381
382   function  Get_Sec_Stack_Soft return  SST.SS_Stack_Ptr;
383   procedure Set_Sec_Stack_Soft (Stack : SST.SS_Stack_Ptr);
384   pragma Inline (Get_Sec_Stack_Soft);
385   pragma Inline (Set_Sec_Stack_Soft);
386
387   --  The following is a dummy record designed to mimic Communication_Block as
388   --  defined in s-tpobop.ads:
389
390   --     type Communication_Block is record
391   --        Self      : Task_Id;  --  An access type
392   --        Enqueued  : Boolean := True;
393   --        Cancelled : Boolean := False;
394   --     end record;
395
396   --  The record is used in the construction of the predefined dispatching
397   --  primitive _disp_asynchronous_select in order to avoid the import of
398   --  System.Tasking.Protected_Objects.Operations. Note that this package
399   --  is always imported in the presence of interfaces since the dispatch
400   --  table uses entities from here.
401
402   type Dummy_Communication_Block is record
403      Comp_1 : Address;  --  Address and access have the same size
404      Comp_2 : Boolean;
405      Comp_3 : Boolean;
406   end record;
407
408private
409   NT_TSD : TSD;
410   --  The task specific data for the main task when the Ada tasking run-time
411   --  is not used. It relies on the default initialization of NT_TSD. It is
412   --  placed here and not the body to ensure the default initialization does
413   --  not clobber the secondary stack initialization that occurs as part of
414   --  System.Soft_Links.Initialization.
415end System.Soft_Links;
416