Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnat/s-stchop.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 RUN-TIME LIBRARY (GNARL) COMPONENTS --
4 -- --
5 -- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1999-2017, Free Software Foundation, Inc. --
10 -- --
11 -- GNARL 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 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 -- This is the general implementation of this package. There is a VxWorks
33 -- specific version of this package (s-stchop-vxworks.adb). This file should
34 -- be kept synchronized with it.
35
36 pragma Restrictions (No_Elaboration_Code);
37 -- We want to guarantee the absence of elaboration code because the
38 -- binder does not handle references to this package.
39
40 with System.Storage_Elements; use System.Storage_Elements;
41 with System.Parameters; use System.Parameters;
42 with System.Soft_Links;
43 with System.CRTL;
44
45 package body System.Stack_Checking.Operations is
46
47 Kilobyte : constant := 1024;
48
49 function Set_Stack_Info
50 (Stack : not null access Stack_Access) return Stack_Access;
51 -- The function Set_Stack_Info is the actual function that updates the
52 -- cache containing a pointer to the Stack_Info. It may also be used for
53 -- detecting asynchronous abort in combination with Invalidate_Self_Cache.
54 --
55 -- Set_Stack_Info should do the following things in order:
56 -- 1) Get the Stack_Access value for the current task
57 -- 2) Set Stack.all to the value obtained in 1)
58 -- 3) Optionally Poll to check for asynchronous abort
59 --
60 -- This order is important because if at any time a write to the stack
61 -- cache is pending, that write should be followed by a Poll to prevent
62 -- losing signals.
63 --
64 -- Note: This function must be compiled with Polling turned off
65 --
66 -- Note: on systems with real thread-local storage, Set_Stack_Info should
67 -- return an access value for such local storage. In those cases the cache
68 -- will always be up-to-date.
69
70 ----------------------------
71 -- Invalidate_Stack_Cache --
72 ----------------------------
73
74 procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access) is
75 pragma Warnings (Off, Any_Stack);
76 begin
77 Cache := Null_Stack;
78 end Invalidate_Stack_Cache;
79
80 -----------------------------
81 -- Notify_Stack_Attributes --
82 -----------------------------
83
84 procedure Notify_Stack_Attributes
85 (Initial_SP : System.Address;
86 Size : System.Storage_Elements.Storage_Offset)
87 is
88 My_Stack : constant Stack_Access := Soft_Links.Get_Stack_Info.all;
89
90 -- We piggyback on the 'Limit' field to store what will be used as the
91 -- 'Base' and leave the 'Size' alone to not interfere with the logic in
92 -- Set_Stack_Info below.
93
94 pragma Unreferenced (Size);
95
96 begin
97 My_Stack.Limit := Initial_SP;
98 end Notify_Stack_Attributes;
99
100 --------------------
101 -- Set_Stack_Info --
102 --------------------
103
104 function Set_Stack_Info
105 (Stack : not null access Stack_Access) return Stack_Access
106 is
107 type Frame_Mark is null record;
108 Frame_Location : Frame_Mark;
109 Frame_Address : constant Address := Frame_Location'Address;
110
111 My_Stack : Stack_Access;
112 Limit_Chars : System.Address;
113 Limit : Integer;
114
115 begin
116 -- The order of steps 1 .. 3 is important, see specification
117
118 -- 1) Get the Stack_Access value for the current task
119
120 My_Stack := Soft_Links.Get_Stack_Info.all;
121
122 if My_Stack.Base = Null_Address then
123
124 -- First invocation, initialize based on the assumption that there
125 -- are Environment_Stack_Size bytes available beyond the current
126 -- frame address.
127
128 if My_Stack.Size = 0 then
129 My_Stack.Size := Storage_Offset (Default_Env_Stack_Size);
130
131 -- When the environment variable GNAT_STACK_LIMIT is set, set
132 -- Environment_Stack_Size to that number of kB.
133
134 Limit_Chars := System.CRTL.getenv ("GNAT_STACK_LIMIT" & ASCII.NUL);
135
136 if Limit_Chars /= Null_Address then
137 Limit := System.CRTL.atoi (Limit_Chars);
138
139 if Limit >= 0 then
140 My_Stack.Size := Storage_Offset (Limit) * Kilobyte;
141 end if;
142 end if;
143 end if;
144
145 -- If a stack base address has been registered, honor it. Fallback to
146 -- the address of a local object otherwise.
147
148 My_Stack.Base :=
149 (if My_Stack.Limit /= System.Null_Address
150 then My_Stack.Limit else Frame_Address);
151
152 if Stack_Grows_Down then
153
154 -- Prevent wrap-around on too big stack sizes
155
156 My_Stack.Limit := My_Stack.Base - My_Stack.Size;
157
158 if My_Stack.Limit > My_Stack.Base then
159 My_Stack.Limit := Address'First;
160 end if;
161
162 else
163 My_Stack.Limit := My_Stack.Base + My_Stack.Size;
164
165 -- Prevent wrap-around on too big stack sizes
166
167 if My_Stack.Limit < My_Stack.Base then
168 My_Stack.Limit := Address'Last;
169 end if;
170 end if;
171 end if;
172
173 -- 2) Set Stack.all to the value obtained in 1)
174
175 Stack.all := My_Stack;
176
177 -- 3) Optionally Poll to check for asynchronous abort
178
179 if Soft_Links.Check_Abort_Status.all /= 0 then
180 raise Standard'Abort_Signal;
181 end if;
182
183 -- Never trust the cached value, but return local copy
184
185 return My_Stack;
186 end Set_Stack_Info;
187
188 -----------------
189 -- Stack_Check --
190 -----------------
191
192 function Stack_Check
193 (Stack_Address : System.Address) return Stack_Access
194 is
195 type Frame_Marker is null record;
196 Marker : Frame_Marker;
197 Cached_Stack : constant Stack_Access := Cache;
198 Frame_Address : constant System.Address := Marker'Address;
199
200 begin
201 -- The parameter may have wrapped around in System.Address arithmetics.
202 -- In that case, we have no other choices than raising the exception.
203
204 if (Stack_Grows_Down and then
205 Stack_Address > Frame_Address)
206 or else
207 (not Stack_Grows_Down and then
208 Stack_Address < Frame_Address)
209 then
210 raise Storage_Error with "stack overflow detected";
211 end if;
212
213 -- This function first does a "cheap" check which is correct if it
214 -- succeeds. In case of failure, the full check is done. Ideally the
215 -- cheap check should be done in an optimized manner, or be inlined.
216
217 if (Stack_Grows_Down and then
218 (Frame_Address <= Cached_Stack.Base
219 and then
220 Stack_Address > Cached_Stack.Limit))
221 or else
222 (not Stack_Grows_Down and then
223 (Frame_Address >= Cached_Stack.Base
224 and then
225 Stack_Address < Cached_Stack.Limit))
226 then
227 -- Cached_Stack is valid as it passed the stack check
228
229 return Cached_Stack;
230 end if;
231
232 Full_Check :
233 declare
234 My_Stack : constant Stack_Access := Set_Stack_Info (Cache'Access);
235 -- At this point Stack.all might already be invalid, so
236 -- it is essential to use our local copy of Stack.
237
238 begin
239 if (Stack_Grows_Down and then
240 (not (Frame_Address <= My_Stack.Base)))
241 or else
242 (not Stack_Grows_Down and then
243 (not (Frame_Address >= My_Stack.Base)))
244 then
245 -- The returned Base is lower than the stored one, so assume that
246 -- the original one wasn't right and use the current Frame_Address
247 -- as new one. This allows Base to be initialized with the
248 -- Frame_Address as approximation. During initialization the
249 -- Frame_Address will be close to the stack base anyway: the
250 -- difference should be compensated for in the stack reserve.
251
252 My_Stack.Base := Frame_Address;
253 end if;
254
255 if (Stack_Grows_Down
256 and then Stack_Address < My_Stack.Limit)
257 or else
258 (not Stack_Grows_Down
259 and then Stack_Address > My_Stack.Limit)
260 then
261 raise Storage_Error with "stack overflow detected";
262 end if;
263
264 return My_Stack;
265 end Full_Check;
266 end Stack_Check;
267
268 ------------------------
269 -- Update_Stack_Cache --
270 ------------------------
271
272 procedure Update_Stack_Cache (Stack : Stack_Access) is
273 begin
274 if not Multi_Processor then
275 Cache := Stack;
276 end if;
277 end Update_Stack_Cache;
278
279 end System.Stack_Checking.Operations;