File : s-soflin-xi.adb
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 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-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 -- --
19 -- --
20 -- --
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 is a Ravenscar bare board version of this body. Tasking version of
33 -- these functions are always used.
34
35 pragma Polling (Off);
36 -- We must turn polling off for this unit, because otherwise we get an
37 -- infinite loop from the code within the Poll routine itself.
38
39 with System.Tasking;
40 with System.Task_Primitives.Operations;
41
42 package body System.Soft_Links is
43
44 use System.Task_Primitives.Operations;
45 use type System.Tasking.Termination_Handler;
46
47 ----------------
48 -- Local data --
49 ----------------
50
51 Caller_Priority : Any_Priority;
52 -- Task's active priority when the global lock is seized. This priority is
53 -- restored when the task releases the global lock.
54
55 ----------------------------
56 -- Get_Current_Excep_Soft --
57 ----------------------------
58
59 function Get_Current_Excep_Soft return EOA is
60 begin
61 return Self.Common.Compiler_Data.Current_Excep'Access;
62 end Get_Current_Excep_Soft;
63
64 ------------------------
65 -- Get_GNAT_Exception --
66 ------------------------
67
68 function Get_GNAT_Exception return Ada.Exceptions.Exception_Id is
69 begin
70 return Ada.Exceptions.Exception_Identity (Get_Current_Excep.all.all);
71 end Get_GNAT_Exception;
72
73 -------------------
74 -- Adafinal_Soft --
75 -------------------
76
77 procedure Adafinal_Soft is
78 begin
79 -- Handle normal task termination by the environment task, but only for
80 -- the normal task termination. Abnormal termination is not supported by
81 -- this run time, and in the case of Unhandled_Exception the last chance
82 -- handler is invoked (which does not return).
83
84 Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence);
85
86 -- Here we should typically finalize all library-level controlled
87 -- objects. However, in Ravenscar tasks (including the environment task)
88 -- are non-terminating, so we avoid finalization.
89
90 -- We used to raise a Program_Error here to signal the task termination
91 -- event in order to avoid silent task death. It has been removed
92 -- because the Ada.Task_Termination functionality serves the same
93 -- purpose in a more flexible (and standard) way. In addition, this
94 -- exception triggered a second execution of the termination handler
95 -- (if any was installed).
96
97 end Adafinal_Soft;
98
99 --------------------
100 -- Task_Lock_Soft --
101 --------------------
102
103 procedure Task_Lock_Soft is
104 Self_Id : constant System.Tasking.Task_Id := Self;
105
106 begin
107 Self_Id.Common.Global_Task_Lock_Nesting :=
108 Self_Id.Common.Global_Task_Lock_Nesting + 1;
109
110 if Self_Id.Common.Global_Task_Lock_Nesting = 1 then
111 declare
112 Prio : constant System.Any_Priority := Get_Priority (Self_Id);
113
114 begin
115 -- Increase priority
116
117 Set_Priority (Self_Id, System.Any_Priority'Last);
118
119 -- Store caller's active priority so that it can be later restored
120 -- when releasing the global lock.
121
122 Caller_Priority := Prio;
123 end;
124 end if;
125 end Task_Lock_Soft;
126
127 ---------------------------
128 -- Task_Termination_Soft --
129 ---------------------------
130
131 procedure Task_Termination_Soft (Except : EO) is
132 pragma Unreferenced (Except);
133
134 Self_Id : constant System.Tasking.Task_Id := Self;
135 TH : System.Tasking.Termination_Handler := null;
136
137 begin
138 -- Raise the priority to prevent race conditions when using
139 -- System.Tasking.Fall_Back_Handler.
140
141 Set_Priority (Self_Id, Any_Priority'Last);
142
143 TH := System.Tasking.Fall_Back_Handler;
144
145 -- Restore original priority after retrieving shared data
146
147 Set_Priority (Self_Id, Self_Id.Common.Base_Priority);
148
149 -- Execute the task termination handler if we found it
150
151 if TH /= null then
152 TH.all (Self_Id);
153 end if;
154 end Task_Termination_Soft;
155
156 ----------------------
157 -- Task_Unlock_Soft --
158 ----------------------
159
160 procedure Task_Unlock_Soft is
161 Self_Id : constant System.Tasking.Task_Id := Self;
162
163 begin
164 pragma Assert (Self_Id.Common.Global_Task_Lock_Nesting > 0);
165
166 Self_Id.Common.Global_Task_Lock_Nesting :=
167 Self_Id.Common.Global_Task_Lock_Nesting - 1;
168
169 if Self_Id.Common.Global_Task_Lock_Nesting = 0 then
170
171 -- Restore the task's active priority
172
173 Set_Priority (Self_Id, Caller_Priority);
174 end if;
175 end Task_Unlock_Soft;
176
177 end System.Soft_Links;