1 ------------------------------------------------------------------------------
3 -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- S Y S T E M . S T A C K _ C H E C K I N G --
10 -- Copyright (C) 1999-2001 Free Software Foundation, Inc. --
12 -- GNARL is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNARL; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- GNARL was developed by the GNARL team at Florida State University. It is --
31 -- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
32 -- State University (http://www.gnat.com). --
34 ------------------------------------------------------------------------------
38 with System
.Storage_Elements
; use System
.Storage_Elements
;
39 with System
.Parameters
; use System
.Parameters
;
40 with System
.Soft_Links
;
42 package body System
.Stack_Checking
is
44 Kilobyte
: constant Storage_Offset
:= 1024;
45 Default_Env_Stack_Size
: constant Storage_Offset
:= 8000 * Kilobyte
;
46 -- This size is assumed for the environment stack when no size has been
47 -- set by the runtime, and no GNAT_STACK_LIMIT environment variable was
48 -- present. The value is chosen to be just under 8 MB whic is the actual
49 -- default size on some systems including GNU/LinuxThreads, so we will get
50 -- correct storage errors on those systems without setting environment
53 function Set_Stack_Info
(Stack
: access Stack_Access
) return Stack_Access
;
55 -- The function Set_Stack_Info is the actual function that updates
56 -- the cache containing a pointer to the Stack_Info. It may also
57 -- be used for detecting asynchronous abort in combination with
58 -- Invalidate_Self_Cache.
60 -- Set_Stack_Info should do the following things in order:
61 -- 1) Get the Stack_Access value for the current task
62 -- 2) Set Stack.all to the value obtained in 1)
63 -- 3) Optionally Poll to check for asynchronous abort
65 -- This order is important because if at any time a write to
66 -- the stack cache is pending, that write should be followed
67 -- by a Poll to prevent loosing signals.
69 -- Note: This function must be compiled with Polling turned off
71 -- Note: on systems like VxWorks and OS/2 with real thread-local storage,
72 -- Set_Stack_Info should return an access value for such local
73 -- storage. In those cases the cache will always be up-to-date.
75 -- The following constants should be imported from some system-specific
76 -- constants package. The constants must be static for performance reasons.
78 ----------------------------
79 -- Invalidate_Stack_Cache --
80 ----------------------------
82 procedure Invalidate_Stack_Cache
(Any_Stack
: Stack_Access
) is
83 pragma Warnings
(Off
, Any_Stack
);
87 end Invalidate_Stack_Cache
;
93 function Set_Stack_Info
94 (Stack
: access Stack_Access
)
97 type Frame_Mark
is null record;
98 Frame_Location
: Frame_Mark
;
99 Frame_Address
: Address
:= Frame_Location
'Address;
101 My_Stack
: Stack_Access
;
102 Limit_Chars
: System
.Address
;
105 function getenv
(S
: String) return System
.Address
;
106 pragma Import
(C
, getenv
, External_Name
=> "getenv");
108 function atoi
(A
: System
.Address
) return Integer;
109 pragma Import
(C
, atoi
);
112 -- The order of steps 1 .. 3 is important, see specification.
114 -- 1) Get the Stack_Access value for the current task
116 My_Stack
:= Soft_Links
.Get_Stack_Info
.all;
118 if My_Stack
.Base
= Null_Address
then
120 -- First invocation, initialize based on the assumption that
121 -- there are Environment_Stack_Size bytes available beyond
122 -- the current frame address.
124 if My_Stack
.Size
= 0 then
126 My_Stack
.Size
:= Default_Env_Stack_Size
;
128 -- When the environment variable GNAT_STACK_LIMIT is set,
129 -- set Environment_Stack_Size to that number of kB.
131 Limit_Chars
:= getenv
("GNAT_STACK_LIMIT" & ASCII
.NUL
);
133 if Limit_Chars
/= Null_Address
then
134 Limit
:= atoi
(Limit_Chars
);
136 My_Stack
.Size
:= Storage_Offset
(Limit
) * Kilobyte
;
141 My_Stack
.Base
:= Frame_Address
;
143 if Stack_Grows_Down
then
145 -- Prevent wrap-around on too big stack sizes
147 My_Stack
.Limit
:= My_Stack
.Base
- My_Stack
.Size
;
149 if My_Stack
.Limit
> My_Stack
.Base
then
150 My_Stack
.Limit
:= Address
'First;
154 My_Stack
.Limit
:= My_Stack
.Base
+ My_Stack
.Size
;
156 -- Prevent wrap-around on too big stack sizes
158 if My_Stack
.Limit
< My_Stack
.Base
then
159 My_Stack
.Limit
:= Address
'Last;
164 -- 2) Set Stack.all to the value obtained in 1)
166 Stack
.all := My_Stack
;
168 -- 3) Optionally Poll to check for asynchronous abort
170 if Soft_Links
.Check_Abort_Status
.all /= 0 then
171 raise Standard
'Abort_Signal;
174 return My_Stack
; -- Never trust the cached value, but return local copy!
181 -- Specify the stack size for the current frame.
183 procedure Set_Stack_Size
184 (Stack_Size
: System
.Storage_Elements
.Storage_Offset
)
186 My_Stack
: Stack_Access
;
187 Frame_Address
: constant System
.Address
:= My_Stack
'Address;
190 My_Stack
:= Stack_Check
(Frame_Address
);
192 if Stack_Grows_Down
then
193 My_Stack
.Limit
:= My_Stack
.Base
- Stack_Size
;
195 My_Stack
.Limit
:= My_Stack
.Base
+ Stack_Size
;
204 (Stack_Address
: System
.Address
)
207 type Frame_Marker
is null record;
208 Marker
: Frame_Marker
;
209 Cached_Stack
: constant Stack_Access
:= Cache
;
210 Frame_Address
: constant System
.Address
:= Marker
'Address;
213 -- This function first does a "cheap" check which is correct
214 -- if it succeeds. In case of failure, the full check is done.
215 -- Ideally the cheap check should be done in an optimized manner,
218 if (Stack_Grows_Down
and then
219 (Frame_Address
<= Cached_Stack
.Base
221 Stack_Address
> Cached_Stack
.Limit
))
223 (not Stack_Grows_Down
and then
224 (Frame_Address
>= Cached_Stack
.Base
226 Stack_Address
< Cached_Stack
.Limit
))
228 -- Cached_Stack is valid as it passed the stack check
234 My_Stack
: 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!
240 if (Stack_Grows_Down
and then
241 (not (Frame_Address
<= My_Stack
.Base
)))
243 (not Stack_Grows_Down
and then
244 (not (Frame_Address
>= My_Stack
.Base
)))
246 -- The returned Base is lower than the stored one,
247 -- so assume that the original one wasn't right and use the
248 -- current Frame_Address as new one. This allows initializing
249 -- Base with the Frame_Address as approximation.
250 -- During initialization the Frame_Address will be close to
251 -- the stack base anyway: the difference should be compensated
252 -- for in the stack reserve.
254 My_Stack
.Base
:= Frame_Address
;
257 if (Stack_Grows_Down
and then
258 Stack_Address
< My_Stack
.Limit
)
260 (not Stack_Grows_Down
and then
261 Stack_Address
> My_Stack
.Limit
)
263 Ada
.Exceptions
.Raise_Exception
264 (E
=> Storage_Error
'Identity,
265 Message
=> "stack overflow detected");
272 ------------------------
273 -- Update_Stack_Cache --
274 ------------------------
276 procedure Update_Stack_Cache
(Stack
: Stack_Access
) is
278 if not Multi_Processor
then
281 end Update_Stack_Cache
;
283 end System
.Stack_Checking
;