Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnat/s-thread__ae653.adb @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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 . T H R E A D S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-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 -- 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
41 package body System.Threads is
42
43 use Interfaces.C;
44
45 package SSL renames System.Soft_Links;
46
47 Current_ATSD : aliased System.Address := System.Null_Address;
48 pragma Export (C, Current_ATSD, "__gnat_current_atsd");
49
50 Main_ATSD : aliased ATSD;
51 -- TSD for environment task
52
53 Stack_Limit : Address;
54
55 pragma Import (C, Stack_Limit, "__gnat_stack_limit");
56
57 type Set_Stack_Limit_Proc_Acc is access procedure;
58 pragma Convention (C, Set_Stack_Limit_Proc_Acc);
59
60 Set_Stack_Limit_Hook : Set_Stack_Limit_Proc_Acc;
61 pragma Import (C, Set_Stack_Limit_Hook, "__gnat_set_stack_limit_hook");
62 -- Procedure to be called when a task is created to set stack limit if
63 -- limit checking is used.
64
65 --------------------------
66 -- VxWorks specific API --
67 --------------------------
68
69 ERROR : constant STATUS := Interfaces.C.int (-1);
70
71 function taskIdVerify (tid : t_id) return STATUS;
72 pragma Import (C, taskIdVerify, "taskIdVerify");
73
74 function taskIdSelf return t_id;
75 pragma Import (C, taskIdSelf, "taskIdSelf");
76
77 function taskVarAdd
78 (tid : t_id; pVar : System.Address) return int;
79 pragma Import (C, taskVarAdd, "taskVarAdd");
80
81 -----------------------
82 -- Local Subprograms --
83 -----------------------
84
85 procedure Init_RTS;
86 -- This procedure performs the initialization of the run-time lib.
87 -- It installs System.Threads versions of certain operations of the
88 -- run-time lib.
89
90 procedure Install_Handler;
91 pragma Import (C, Install_Handler, "__gnat_install_handler");
92
93 function Get_Sec_Stack return SST.SS_Stack_Ptr;
94
95 procedure Set_Sec_Stack (Stack : SST.SS_Stack_Ptr);
96
97 -----------------------
98 -- Thread_Body_Enter --
99 -----------------------
100
101 procedure Thread_Body_Enter
102 (Sec_Stack_Ptr : SST.SS_Stack_Ptr;
103 Process_ATSD_Address : System.Address)
104 is
105 -- Current_ATSD must already be a taskVar of taskIdSelf.
106 -- No assertion because taskVarGet is not available on VxWorks/CERT,
107 -- which is used on VxWorks 653 3.x as a guest OS.
108
109 TSD : constant ATSD_Access := From_Address (Process_ATSD_Address);
110
111 begin
112
113 TSD.Sec_Stack_Ptr := Sec_Stack_Ptr;
114 SST.SS_Init (TSD.Sec_Stack_Ptr);
115 Current_ATSD := Process_ATSD_Address;
116
117 Install_Handler;
118
119 -- Initialize stack limit if needed
120
121 if Current_ATSD /= Main_ATSD'Address
122 and then Set_Stack_Limit_Hook /= null
123 then
124 Set_Stack_Limit_Hook.all;
125 end if;
126 end Thread_Body_Enter;
127
128 ----------------------------------
129 -- Thread_Body_Exceptional_Exit --
130 ----------------------------------
131
132 procedure Thread_Body_Exceptional_Exit
133 (EO : Ada.Exceptions.Exception_Occurrence)
134 is
135 pragma Unreferenced (EO);
136
137 begin
138 -- No action for this target
139
140 null;
141 end Thread_Body_Exceptional_Exit;
142
143 -----------------------
144 -- Thread_Body_Leave --
145 -----------------------
146
147 procedure Thread_Body_Leave is
148 begin
149 -- No action for this target
150
151 null;
152 end Thread_Body_Leave;
153
154 --------------
155 -- Init_RTS --
156 --------------
157
158 procedure Init_RTS is
159 -- Register environment task
160 Result : constant Interfaces.C.int := Register (taskIdSelf);
161 pragma Assert (Result /= ERROR);
162
163 begin
164 Main_ATSD.Sec_Stack_Ptr := SSL.Get_Sec_Stack_NT;
165 Current_ATSD := Main_ATSD'Address;
166 Install_Handler;
167 SSL.Get_Sec_Stack := Get_Sec_Stack'Access;
168 SSL.Set_Sec_Stack := Set_Sec_Stack'Access;
169 end Init_RTS;
170
171 -------------------
172 -- Get_Sec_Stack --
173 -------------------
174
175 function Get_Sec_Stack return SST.SS_Stack_Ptr is
176 CTSD : constant ATSD_Access := From_Address (Current_ATSD);
177 begin
178 pragma Assert (CTSD /= null);
179 return CTSD.Sec_Stack_Ptr;
180 end Get_Sec_Stack;
181
182 --------------
183 -- Register --
184 --------------
185
186 function Register (T : Thread_Id) return STATUS is
187 Result : STATUS;
188
189 begin
190 -- It cannot be assumed that the caller of this routine has a ATSD;
191 -- so neither this procedure nor the procedures that it calls should
192 -- raise or handle exceptions, or make use of a secondary stack.
193
194 -- This routine is only necessary because taskVarAdd cannot be
195 -- executed once an VxWorks 653 partition has entered normal mode
196 -- (depending on configRecord.c, allocation could be disabled).
197 -- Otherwise, everything could have been done in Thread_Body_Enter.
198
199 if taskIdVerify (T) = ERROR then
200 return ERROR;
201 end if;
202
203 Result := taskVarAdd (T, Current_ATSD'Address);
204 pragma Assert (Result /= ERROR);
205
206 -- The same issue applies to the task variable that contains the stack
207 -- limit when that overflow checking mechanism is used instead of
208 -- probing. If stack checking is enabled and limit checking is used,
209 -- allocate the limit for this task. The environment task has this
210 -- initialized by the binder-generated main when
211 -- System.Stack_Check_Limits = True.
212
213 pragma Warnings (Off);
214 -- OS is a constant
215 if Result /= ERROR
216 and then OS /= VxWorks_653
217 and then Set_Stack_Limit_Hook /= null
218 then
219 Result := taskVarAdd (T, Stack_Limit'Address);
220 pragma Assert (Result /= ERROR);
221 end if;
222 pragma Warnings (On);
223
224 return Result;
225 end Register;
226
227 -------------------
228 -- Set_Sec_Stack --
229 -------------------
230
231 procedure Set_Sec_Stack (Stack : SST.SS_Stack_Ptr) is
232 CTSD : constant ATSD_Access := From_Address (Current_ATSD);
233 begin
234 pragma Assert (CTSD /= null);
235 CTSD.Sec_Stack_Ptr := Stack;
236 end Set_Sec_Stack;
237
238 begin
239 -- Initialize run-time library
240
241 Init_RTS;
242 end System.Threads;