1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--             S Y S T E M . S O F T _ L I N K S . T A S K I N G            --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 2004-2015, 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
32pragma Style_Checks (All_Checks);
33--  Turn off subprogram alpha ordering check, since we group soft link bodies
34--  and dummy soft link bodies together separately in this unit.
35
36pragma Polling (Off);
37--  Turn polling off for this package. We don't need polling during any of the
38--  routines in this package, and more to the point, if we try to poll it can
39--  cause infinite loops.
40
41with Ada.Exceptions;
42with Ada.Exceptions.Is_Null_Occurrence;
43
44with System.Task_Primitives.Operations;
45with System.Tasking;
46with System.Stack_Checking;
47
48package body System.Soft_Links.Tasking is
49
50   package STPO renames System.Task_Primitives.Operations;
51   package SSL  renames System.Soft_Links;
52
53   use Ada.Exceptions;
54
55   use type System.Tasking.Task_Id;
56   use type System.Tasking.Termination_Handler;
57
58   ----------------
59   -- Local Data --
60   ----------------
61
62   Initialized : Boolean := False;
63   --  Boolean flag that indicates whether the tasking soft links have
64   --  already been set.
65
66   -----------------------------------------------------------------
67   -- Tasking Versions of Services Needed by Non-Tasking Programs --
68   -----------------------------------------------------------------
69
70   function  Get_Jmpbuf_Address return  Address;
71   procedure Set_Jmpbuf_Address (Addr : Address);
72   --  Get/Set Jmpbuf_Address for current task
73
74   function  Get_Sec_Stack_Addr return  Address;
75   procedure Set_Sec_Stack_Addr (Addr : Address);
76   --  Get/Set location of current task's secondary stack
77
78   procedure Timed_Delay_T (Time : Duration; Mode : Integer);
79   --  Task-safe version of SSL.Timed_Delay
80
81   procedure Task_Termination_Handler_T  (Excep : SSL.EO);
82   --  Task-safe version of the task termination procedure
83
84   function Get_Stack_Info return Stack_Checking.Stack_Access;
85   --  Get access to the current task's Stack_Info
86
87   --------------------------
88   -- Soft-Link Get Bodies --
89   --------------------------
90
91   function Get_Jmpbuf_Address return  Address is
92   begin
93      return STPO.Self.Common.Compiler_Data.Jmpbuf_Address;
94   end Get_Jmpbuf_Address;
95
96   function Get_Sec_Stack_Addr return  Address is
97   begin
98      return Result : constant Address :=
99        STPO.Self.Common.Compiler_Data.Sec_Stack_Addr
100      do
101         pragma Assert (Result /= Null_Address);
102      end return;
103   end Get_Sec_Stack_Addr;
104
105   function Get_Stack_Info return Stack_Checking.Stack_Access is
106   begin
107      return STPO.Self.Common.Compiler_Data.Pri_Stack_Info'Access;
108   end Get_Stack_Info;
109
110   --------------------------
111   -- Soft-Link Set Bodies --
112   --------------------------
113
114   procedure Set_Jmpbuf_Address (Addr : Address) is
115   begin
116      STPO.Self.Common.Compiler_Data.Jmpbuf_Address := Addr;
117   end Set_Jmpbuf_Address;
118
119   procedure Set_Sec_Stack_Addr (Addr : Address) is
120   begin
121      STPO.Self.Common.Compiler_Data.Sec_Stack_Addr := Addr;
122   end Set_Sec_Stack_Addr;
123
124   -------------------
125   -- Timed_Delay_T --
126   -------------------
127
128   procedure Timed_Delay_T (Time : Duration; Mode : Integer) is
129      Self_Id : constant System.Tasking.Task_Id := STPO.Self;
130
131   begin
132      --  In case pragma Detect_Blocking is active then Program_Error
133      --  must be raised if this potentially blocking operation
134      --  is called from a protected operation.
135
136      if System.Tasking.Detect_Blocking
137        and then Self_Id.Common.Protected_Action_Nesting > 0
138      then
139         raise Program_Error with "potentially blocking operation";
140      else
141         Abort_Defer.all;
142         STPO.Timed_Delay (Self_Id, Time, Mode);
143         Abort_Undefer.all;
144      end if;
145   end Timed_Delay_T;
146
147   --------------------------------
148   -- Task_Termination_Handler_T --
149   --------------------------------
150
151   procedure Task_Termination_Handler_T (Excep : SSL.EO) is
152      Self_Id : constant System.Tasking.Task_Id := STPO.Self;
153      Cause   : System.Tasking.Cause_Of_Termination;
154      EO      : Ada.Exceptions.Exception_Occurrence;
155
156   begin
157      --  We can only be here because we are terminating the environment task.
158      --  Task termination for all other tasks is handled in the Task_Wrapper.
159
160      --  We do not want to enable this check and e.g. call System.OS_Lib.Abort
161      --  here because some restricted run-times may not have System.OS_Lib
162      --  and calling abort may do more harm than good to the main application.
163
164      pragma Assert (Self_Id = STPO.Environment_Task);
165
166      --  Normal task termination
167
168      if Is_Null_Occurrence (Excep) then
169         Cause := System.Tasking.Normal;
170         Ada.Exceptions.Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence);
171
172      --  Abnormal task termination
173
174      elsif Exception_Identity (Excep) = Standard'Abort_Signal'Identity then
175         Cause := System.Tasking.Abnormal;
176         Ada.Exceptions.Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence);
177
178      --  Termination because of an unhandled exception
179
180      else
181         Cause := System.Tasking.Unhandled_Exception;
182         Ada.Exceptions.Save_Occurrence (EO, Excep);
183      end if;
184
185      --  There is no need for explicit protection against race conditions for
186      --  this part because it can only be executed by the environment task
187      --  after all the other tasks have been finalized. Note that there is no
188      --  fall-back handler which could apply to this environment task because
189      --  it has no parents, and, as specified in ARM C.7.3 par. 9/2, "the
190      --  fall-back handler applies only to the dependent tasks of the task".
191
192      if Self_Id.Common.Specific_Handler /= null then
193         Self_Id.Common.Specific_Handler.all (Cause, Self_Id, EO);
194      end if;
195   end Task_Termination_Handler_T;
196
197   -----------------------------
198   -- Init_Tasking_Soft_Links --
199   -----------------------------
200
201   procedure Init_Tasking_Soft_Links is
202   begin
203      --  Set links only if not set already
204
205      if not Initialized then
206
207         --  Mark tasking soft links as initialized
208
209         Initialized := True;
210
211         --  The application being executed uses tasking so that the tasking
212         --  version of the following soft links need to be used.
213
214         SSL.Get_Jmpbuf_Address       := Get_Jmpbuf_Address'Access;
215         SSL.Set_Jmpbuf_Address       := Set_Jmpbuf_Address'Access;
216         SSL.Get_Sec_Stack_Addr       := Get_Sec_Stack_Addr'Access;
217         SSL.Get_Stack_Info           := Get_Stack_Info'Access;
218         SSL.Set_Sec_Stack_Addr       := Set_Sec_Stack_Addr'Access;
219         SSL.Timed_Delay              := Timed_Delay_T'Access;
220         SSL.Task_Termination_Handler := Task_Termination_Handler_T'Access;
221
222         --  No need to create a new secondary stack, since we will use the
223         --  default one created in s-secsta.adb.
224
225         SSL.Set_Sec_Stack_Addr     (SSL.Get_Sec_Stack_Addr_NT);
226         SSL.Set_Jmpbuf_Address     (SSL.Get_Jmpbuf_Address_NT);
227      end if;
228
229      pragma Assert (Get_Sec_Stack_Addr /= Null_Address);
230   end Init_Tasking_Soft_Links;
231
232end System.Soft_Links.Tasking;
233