File : s-thread-ae653.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S Y S T E M . T H R E A D 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 the VxWorks 653 version of this package
33
34 pragma Restrictions (No_Tasking);
35 -- The VxWorks 653 version of this package is intended only for programs
36 -- which do not use Ada tasking. This restriction ensures that this
37 -- will be checked by the binder.
38
39 with System.OS_Versions; use System.OS_Versions;
40 with System.Secondary_Stack;
41 pragma Elaborate_All (System.Secondary_Stack);
42
43 package body System.Threads is
44
45 use Interfaces.C;
46
47 package SSS renames System.Secondary_Stack;
48
49 package SSL renames System.Soft_Links;
50
51 Current_ATSD : aliased System.Address := System.Null_Address;
52 pragma Export (C, Current_ATSD, "__gnat_current_atsd");
53
54 subtype EOA is Ada.Exceptions.Exception_Occurrence_Access;
55
56 Main_ATSD : aliased ATSD;
57 -- TSD for environment task
58
59 Stack_Limit : Address;
60
61 pragma Import (C, Stack_Limit, "__gnat_stack_limit");
62
63 type Set_Stack_Limit_Proc_Acc is access procedure;
64 pragma Convention (C, Set_Stack_Limit_Proc_Acc);
65
66 Set_Stack_Limit_Hook : Set_Stack_Limit_Proc_Acc;
67 pragma Import (C, Set_Stack_Limit_Hook, "__gnat_set_stack_limit_hook");
68 -- Procedure to be called when a task is created to set stack limit if
69 -- limit checking is used.
70
71 --------------------------
72 -- VxWorks specific API --
73 --------------------------
74
75 ERROR : constant STATUS := Interfaces.C.int (-1);
76
77 function taskIdVerify (tid : t_id) return STATUS;
78 pragma Import (C, taskIdVerify, "taskIdVerify");
79
80 function taskIdSelf return t_id;
81 pragma Import (C, taskIdSelf, "taskIdSelf");
82
83 function taskVarAdd
84 (tid : t_id; pVar : System.Address) return int;
85 pragma Import (C, taskVarAdd, "taskVarAdd");
86
87 -----------------------
88 -- Local Subprograms --
89 -----------------------
90
91 procedure Init_RTS;
92 -- This procedure performs the initialization of the run-time lib.
93 -- It installs System.Threads versions of certain operations of the
94 -- run-time lib.
95
96 procedure Install_Handler;
97 pragma Import (C, Install_Handler, "__gnat_install_handler");
98
99 function Get_Jmpbuf_Address return Address;
100 pragma Inline (Get_Jmpbuf_Address);
101
102 procedure Set_Jmpbuf_Address (Addr : Address);
103 pragma Inline (Set_Jmpbuf_Address);
104
105 function Get_Sec_Stack_Addr return Address;
106 pragma Inline (Get_Sec_Stack_Addr);
107
108 procedure Set_Sec_Stack_Addr (Addr : Address);
109 pragma Inline (Set_Sec_Stack_Addr);
110
111 function Get_Current_Excep return EOA;
112 pragma Inline (Get_Current_Excep);
113
114 -----------------------
115 -- Thread_Body_Enter --
116 -----------------------
117
118 procedure Thread_Body_Enter
119 (Sec_Stack_Address : System.Address;
120 Sec_Stack_Size : Natural;
121 Process_ATSD_Address : System.Address)
122 is
123 -- Current_ATSD must already be a taskVar of taskIdSelf.
124 -- No assertion because taskVarGet is not available on VxWorks/CERT,
125 -- which is used on VxWorks 653 3.x as a guest OS.
126
127 TSD : constant ATSD_Access := From_Address (Process_ATSD_Address);
128
129 begin
130
131 TSD.Sec_Stack_Addr := Sec_Stack_Address;
132 SSS.SS_Init (TSD.Sec_Stack_Addr, Sec_Stack_Size);
133 Current_ATSD := Process_ATSD_Address;
134
135 Install_Handler;
136
137 -- Initialize stack limit if needed
138
139 if Current_ATSD /= Main_ATSD'Address
140 and then Set_Stack_Limit_Hook /= null
141 then
142 Set_Stack_Limit_Hook.all;
143 end if;
144 end Thread_Body_Enter;
145
146 ----------------------------------
147 -- Thread_Body_Exceptional_Exit --
148 ----------------------------------
149
150 procedure Thread_Body_Exceptional_Exit
151 (EO : Ada.Exceptions.Exception_Occurrence)
152 is
153 pragma Unreferenced (EO);
154
155 begin
156 -- No action for this target
157
158 null;
159 end Thread_Body_Exceptional_Exit;
160
161 -----------------------
162 -- Thread_Body_Leave --
163 -----------------------
164
165 procedure Thread_Body_Leave is
166 begin
167 -- No action for this target
168
169 null;
170 end Thread_Body_Leave;
171
172 --------------
173 -- Init_RTS --
174 --------------
175
176 procedure Init_RTS is
177 -- Register environment task
178 Result : constant Interfaces.C.int := Register (taskIdSelf);
179 pragma Assert (Result /= ERROR);
180
181 begin
182 Main_ATSD.Sec_Stack_Addr := SSL.Get_Sec_Stack_Addr_NT;
183 Current_ATSD := Main_ATSD'Address;
184 Install_Handler;
185 SSL.Get_Jmpbuf_Address := Get_Jmpbuf_Address'Access;
186 SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access;
187 SSL.Get_Current_Excep := Get_Current_Excep'Access;
188 SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access;
189 SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access;
190 end Init_RTS;
191
192 -----------------------
193 -- Get_Current_Excep --
194 -----------------------
195
196 function Get_Current_Excep return EOA is
197 CTSD : ATSD_Access := From_Address (Current_ATSD);
198 begin
199 pragma Assert (Current_ATSD /= System.Null_Address);
200 return CTSD.Current_Excep'Access;
201 end Get_Current_Excep;
202
203 ------------------------
204 -- Get_Jmpbuf_Address --
205 ------------------------
206
207 function Get_Jmpbuf_Address return Address is
208 CTSD : constant ATSD_Access := From_Address (Current_ATSD);
209 begin
210 pragma Assert (Current_ATSD /= System.Null_Address);
211 return CTSD.Jmpbuf_Address;
212 end Get_Jmpbuf_Address;
213
214 ------------------------
215 -- Get_Sec_Stack_Addr --
216 ------------------------
217
218 function Get_Sec_Stack_Addr return Address is
219 CTSD : constant ATSD_Access := From_Address (Current_ATSD);
220 begin
221 pragma Assert (Current_ATSD /= System.Null_Address);
222 return CTSD.Sec_Stack_Addr;
223 end Get_Sec_Stack_Addr;
224
225 --------------
226 -- Register --
227 --------------
228
229 function Register (T : Thread_Id) return STATUS is
230 Result : STATUS;
231
232 begin
233 -- It cannot be assumed that the caller of this routine has a ATSD;
234 -- so neither this procedure nor the procedures that it calls should
235 -- raise or handle exceptions, or make use of a secondary stack.
236
237 -- This routine is only necessary because taskVarAdd cannot be
238 -- executed once an VxWorks 653 partition has entered normal mode
239 -- (depending on configRecord.c, allocation could be disabled).
240 -- Otherwise, everything could have been done in Thread_Body_Enter.
241
242 if taskIdVerify (T) = ERROR then
243 return ERROR;
244 end if;
245
246 Result := taskVarAdd (T, Current_ATSD'Address);
247 pragma Assert (Result /= ERROR);
248
249 -- The same issue applies to the task variable that contains the stack
250 -- limit when that overflow checking mechanism is used instead of
251 -- probing. If stack checking is enabled and limit checking is used,
252 -- allocate the limit for this task. The environment task has this
253 -- initialized by the binder-generated main when
254 -- System.Stack_Check_Limits = True.
255
256 pragma Warnings (Off);
257 -- OS is a constant
258 if Result /= ERROR
259 and then OS /= VxWorks_653
260 and then Set_Stack_Limit_Hook /= null
261 then
262 Result := taskVarAdd (T, Stack_Limit'Address);
263 pragma Assert (Result /= ERROR);
264 end if;
265 pragma Warnings (On);
266
267 return Result;
268 end Register;
269
270 ------------------------
271 -- Set_Jmpbuf_Address --
272 ------------------------
273
274 procedure Set_Jmpbuf_Address (Addr : Address) is
275 CTSD : constant ATSD_Access := From_Address (Current_ATSD);
276 begin
277 pragma Assert (Current_ATSD /= System.Null_Address);
278 CTSD.Jmpbuf_Address := Addr;
279 end Set_Jmpbuf_Address;
280
281 ------------------------
282 -- Set_Sec_Stack_Addr --
283 ------------------------
284
285 procedure Set_Sec_Stack_Addr (Addr : Address) is
286 CTSD : constant ATSD_Access := From_Address (Current_ATSD);
287 begin
288 pragma Assert (Current_ATSD /= System.Null_Address);
289 CTSD.Sec_Stack_Addr := Addr;
290 end Set_Sec_Stack_Addr;
291
292 begin
293 -- Initialize run-time library
294
295 Init_RTS;
296 end System.Threads;