Mercurial > hg > CbC > CbC_gcc
comparison gcc/ada/libgnarl/s-solita.adb @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
comparison
equal
deleted
inserted
replaced
68:561a7518be6b | 111:04ced10e8804 |
---|---|
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-2017, 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 pragma 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 | |
36 pragma 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 | |
41 with Ada.Exceptions; | |
42 with Ada.Exceptions.Is_Null_Occurrence; | |
43 | |
44 with System.Task_Primitives.Operations; | |
45 with System.Tasking; | |
46 with System.Stack_Checking; | |
47 with System.Secondary_Stack; | |
48 | |
49 package body System.Soft_Links.Tasking is | |
50 | |
51 package STPO renames System.Task_Primitives.Operations; | |
52 package SSL renames System.Soft_Links; | |
53 | |
54 use Ada.Exceptions; | |
55 | |
56 use type System.Secondary_Stack.SS_Stack_Ptr; | |
57 | |
58 use type System.Tasking.Task_Id; | |
59 use type System.Tasking.Termination_Handler; | |
60 | |
61 ---------------- | |
62 -- Local Data -- | |
63 ---------------- | |
64 | |
65 Initialized : Boolean := False; | |
66 -- Boolean flag that indicates whether the tasking soft links have | |
67 -- already been set. | |
68 | |
69 ----------------------------------------------------------------- | |
70 -- Tasking Versions of Services Needed by Non-Tasking Programs -- | |
71 ----------------------------------------------------------------- | |
72 | |
73 function Get_Jmpbuf_Address return Address; | |
74 procedure Set_Jmpbuf_Address (Addr : Address); | |
75 -- Get/Set Jmpbuf_Address for current task | |
76 | |
77 function Get_Sec_Stack return SST.SS_Stack_Ptr; | |
78 procedure Set_Sec_Stack (Stack : SST.SS_Stack_Ptr); | |
79 -- Get/Set location of current task's secondary stack | |
80 | |
81 procedure Timed_Delay_T (Time : Duration; Mode : Integer); | |
82 -- Task-safe version of SSL.Timed_Delay | |
83 | |
84 procedure Task_Termination_Handler_T (Excep : SSL.EO); | |
85 -- Task-safe version of the task termination procedure | |
86 | |
87 function Get_Stack_Info return Stack_Checking.Stack_Access; | |
88 -- Get access to the current task's Stack_Info | |
89 | |
90 -------------------------- | |
91 -- Soft-Link Get Bodies -- | |
92 -------------------------- | |
93 | |
94 function Get_Jmpbuf_Address return Address is | |
95 begin | |
96 return STPO.Self.Common.Compiler_Data.Jmpbuf_Address; | |
97 end Get_Jmpbuf_Address; | |
98 | |
99 function Get_Sec_Stack return SST.SS_Stack_Ptr is | |
100 begin | |
101 return Result : constant SST.SS_Stack_Ptr := | |
102 STPO.Self.Common.Compiler_Data.Sec_Stack_Ptr | |
103 do | |
104 pragma Assert (Result /= null); | |
105 end return; | |
106 end Get_Sec_Stack; | |
107 | |
108 function Get_Stack_Info return Stack_Checking.Stack_Access is | |
109 begin | |
110 return STPO.Self.Common.Compiler_Data.Pri_Stack_Info'Access; | |
111 end Get_Stack_Info; | |
112 | |
113 -------------------------- | |
114 -- Soft-Link Set Bodies -- | |
115 -------------------------- | |
116 | |
117 procedure Set_Jmpbuf_Address (Addr : Address) is | |
118 begin | |
119 STPO.Self.Common.Compiler_Data.Jmpbuf_Address := Addr; | |
120 end Set_Jmpbuf_Address; | |
121 | |
122 procedure Set_Sec_Stack (Stack : SST.SS_Stack_Ptr) is | |
123 begin | |
124 STPO.Self.Common.Compiler_Data.Sec_Stack_Ptr := Stack; | |
125 end Set_Sec_Stack; | |
126 | |
127 ------------------- | |
128 -- Timed_Delay_T -- | |
129 ------------------- | |
130 | |
131 procedure Timed_Delay_T (Time : Duration; Mode : Integer) is | |
132 Self_Id : constant System.Tasking.Task_Id := STPO.Self; | |
133 | |
134 begin | |
135 -- In case pragma Detect_Blocking is active then Program_Error | |
136 -- must be raised if this potentially blocking operation | |
137 -- is called from a protected operation. | |
138 | |
139 if System.Tasking.Detect_Blocking | |
140 and then Self_Id.Common.Protected_Action_Nesting > 0 | |
141 then | |
142 raise Program_Error with "potentially blocking operation"; | |
143 else | |
144 Abort_Defer.all; | |
145 STPO.Timed_Delay (Self_Id, Time, Mode); | |
146 Abort_Undefer.all; | |
147 end if; | |
148 end Timed_Delay_T; | |
149 | |
150 -------------------------------- | |
151 -- Task_Termination_Handler_T -- | |
152 -------------------------------- | |
153 | |
154 procedure Task_Termination_Handler_T (Excep : SSL.EO) is | |
155 Self_Id : constant System.Tasking.Task_Id := STPO.Self; | |
156 Cause : System.Tasking.Cause_Of_Termination; | |
157 EO : Ada.Exceptions.Exception_Occurrence; | |
158 | |
159 begin | |
160 -- We can only be here because we are terminating the environment task. | |
161 -- Task termination for all other tasks is handled in the Task_Wrapper. | |
162 | |
163 -- We do not want to enable this check and e.g. call System.OS_Lib.Abort | |
164 -- here because some restricted run-times may not have System.OS_Lib | |
165 -- and calling abort may do more harm than good to the main application. | |
166 | |
167 pragma Assert (Self_Id = STPO.Environment_Task); | |
168 | |
169 -- Normal task termination | |
170 | |
171 if Is_Null_Occurrence (Excep) then | |
172 Cause := System.Tasking.Normal; | |
173 Ada.Exceptions.Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence); | |
174 | |
175 -- Abnormal task termination | |
176 | |
177 elsif Exception_Identity (Excep) = Standard'Abort_Signal'Identity then | |
178 Cause := System.Tasking.Abnormal; | |
179 Ada.Exceptions.Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence); | |
180 | |
181 -- Termination because of an unhandled exception | |
182 | |
183 else | |
184 Cause := System.Tasking.Unhandled_Exception; | |
185 Ada.Exceptions.Save_Occurrence (EO, Excep); | |
186 end if; | |
187 | |
188 -- There is no need for explicit protection against race conditions for | |
189 -- this part because it can only be executed by the environment task | |
190 -- after all the other tasks have been finalized. Note that there is no | |
191 -- fall-back handler which could apply to this environment task because | |
192 -- it has no parents, and, as specified in ARM C.7.3 par. 9/2, "the | |
193 -- fall-back handler applies only to the dependent tasks of the task". | |
194 | |
195 if Self_Id.Common.Specific_Handler /= null then | |
196 Self_Id.Common.Specific_Handler.all (Cause, Self_Id, EO); | |
197 end if; | |
198 end Task_Termination_Handler_T; | |
199 | |
200 ----------------------------- | |
201 -- Init_Tasking_Soft_Links -- | |
202 ----------------------------- | |
203 | |
204 procedure Init_Tasking_Soft_Links is | |
205 begin | |
206 -- Set links only if not set already | |
207 | |
208 if not Initialized then | |
209 | |
210 -- Mark tasking soft links as initialized | |
211 | |
212 Initialized := True; | |
213 | |
214 -- The application being executed uses tasking so that the tasking | |
215 -- version of the following soft links need to be used. | |
216 | |
217 SSL.Get_Jmpbuf_Address := Get_Jmpbuf_Address'Access; | |
218 SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access; | |
219 SSL.Get_Sec_Stack := Get_Sec_Stack'Access; | |
220 SSL.Get_Stack_Info := Get_Stack_Info'Access; | |
221 SSL.Set_Sec_Stack := Set_Sec_Stack'Access; | |
222 SSL.Timed_Delay := Timed_Delay_T'Access; | |
223 SSL.Task_Termination_Handler := Task_Termination_Handler_T'Access; | |
224 | |
225 -- No need to create a new secondary stack, since we will use the | |
226 -- default one created in s-secsta.adb. | |
227 | |
228 SSL.Set_Sec_Stack (SSL.Get_Sec_Stack_NT); | |
229 SSL.Set_Jmpbuf_Address (SSL.Get_Jmpbuf_Address_NT); | |
230 end if; | |
231 | |
232 pragma Assert (Get_Sec_Stack /= null); | |
233 end Init_Tasking_Soft_Links; | |
234 | |
235 end System.Soft_Links.Tasking; |