File : s-init-vxworks-cert.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME COMPONENTS --
4 -- --
5 -- S Y S T E M . I N I T --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2003-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 Level A cert version for VxWorks 6 Cert, VxWorks 653, and MILS
33
34 -- This file should be kept synchronized with init.c, s-osvers-*.ads, and
35 -- s-init-xi-sparc.adb. All these files implement the required functionality
36 -- for different targets.
37
38 with Interfaces.C;
39 with System.OS_Versions;
40
41 package body System.Init is
42
43 use Interfaces.C, System.OS_Versions;
44
45 Stack_Limit_Hook : System.Address;
46 pragma Export (C, Stack_Limit_Hook, "__gnat_set_stack_limit_hook");
47 -- Used when stack limit checking is the stack overflow checking method
48
49 -----------------------------
50 -- Binder Generated Values --
51 -----------------------------
52
53 Gl_Main_Priority : Integer := -1;
54 pragma Export (C, Gl_Main_Priority, "__gl_main_priority");
55
56 Gl_Main_CPU : Integer := -1;
57 pragma Export (C, Gl_Main_CPU, "__gl_main_cpu");
58
59 ------------------------
60 -- Signal Definitions --
61 ------------------------
62
63 NSIG : constant := 32;
64 -- Number of signals on the target OS
65
66 type Signal is new int range 0 .. Interfaces.C."-" (NSIG, 1);
67
68 SIGILL : constant := 4; -- illegal instruction (not reset)
69 SIGFPE : constant := 8; -- floating point exception
70 SIGBUS : constant := 10; -- bus error
71 SIGSEGV : constant := 11; -- segmentation violation
72
73 type sigset_t is
74 mod 2 ** (case OS is
75 when VxWorks_Cert |
76 VxWorks_Cert_RTP => Long_Long_Integer'Size,
77 when others => Long_Integer'Size);
78
79 SIG_SETMASK : constant := 3;
80 SA_ONSTACK : constant := 16#0004#;
81
82 type struct_sigaction is record
83 sa_handler : System.Address;
84 sa_mask : sigset_t;
85 sa_flags : int;
86 end record;
87 pragma Convention (C, struct_sigaction);
88 type struct_sigaction_ptr is access all struct_sigaction;
89
90 function sigdelset (set : access sigset_t; sig : Signal) return int;
91 pragma Import (C, sigdelset, "sigdelset");
92
93 function sigemptyset (set : access sigset_t) return int;
94 pragma Import (C, sigemptyset, "sigemptyset");
95
96 function sigaction
97 (sig : Signal;
98 act : struct_sigaction_ptr;
99 oact : struct_sigaction_ptr) return int;
100 pragma Import (C, sigaction, "sigaction");
101
102 type sigset_t_ptr is access all sigset_t;
103
104 function pthread_sigmask
105 (how : int;
106 set : sigset_t_ptr;
107 oset : sigset_t_ptr) return int;
108 pragma Import (C, pthread_sigmask, "sigprocmask");
109
110 ----------------------
111 -- Local Procedures --
112 ----------------------
113
114 procedure Clear_Exception_Count;
115 pragma Import (C, Clear_Exception_Count, "__gnat_clear_exception_count");
116 -- Clear count of nested hardware exceptions when handling signal, as
117 -- required for vThreads.
118
119 procedure GNAT_Error_Handler (Sig : Signal);
120 pragma No_Return (GNAT_Error_Handler);
121 -- Common procedure that is executed when a SIGFPE, SIGILL, SIGSEGV, or
122 -- SIGBUS is captured.
123
124 ------------------------
125 -- GNAT_Error_Handler --
126 ------------------------
127
128 procedure GNAT_Error_Handler (Sig : Signal) is
129 Mask : aliased sigset_t;
130 Result : int;
131 pragma Unreferenced (Result);
132
133 begin
134 -- VxWorks will always mask out the signal during the signal handler and
135 -- will reenable it on a longjmp. GNAT does not generate a longjmp to
136 -- return from a signal handler so the signal will still be masked
137 -- unless we unmask it.
138
139 Result := pthread_sigmask (SIG_SETMASK, null, Mask'Unchecked_Access);
140 Result := sigdelset (Mask'Unchecked_Access, Sig);
141 Result := pthread_sigmask (SIG_SETMASK, Mask'Unchecked_Access, null);
142 Clear_Exception_Count;
143
144 -- The VxWorks MILS VxWorks 5 Guest OS and Vx6Cert do not support stack
145 -- probing via guard pages, so the use of signals differs from the other
146 -- VxWorks variants. Warnings are off because of constant condition
147 -- values.
148
149 pragma Warnings (Off);
150 case Sig is
151 when SIGFPE =>
152 raise Constraint_Error with "SIGFPE";
153
154 when SIGILL =>
155 if OS = VxWorks_MILS or else OS = VxWorks_Cert then
156 raise Storage_Error with "possible stack overflow, SIGILL";
157 elsif OS = VxWorks_653 then
158 raise Constraint_Error with "Floating point overflow or SIGILL";
159 else
160 raise Constraint_Error with "SIGILL";
161 end if;
162
163 when SIGSEGV =>
164 raise Storage_Error with "SIGSEGV";
165
166 when SIGBUS =>
167 if OS = VxWorks_MILS or else OS = VxWorks_Cert then
168 raise Program_Error with "SIGBUS";
169 else
170 raise Storage_Error with "possible stack overflow, SIGBUS";
171 end if;
172
173 when others =>
174 raise Program_Error with "unexpected signal";
175 end case;
176 pragma Warnings (On);
177 end GNAT_Error_Handler;
178
179 ---------------------
180 -- Install_Handler --
181 ---------------------
182
183 procedure Install_Handler is
184 Mask : aliased sigset_t;
185 Signal_Action : aliased struct_sigaction;
186
187 Result : Interfaces.C.int;
188 pragma Unreferenced (Result);
189
190 begin
191 -- Set up signal handler to map synchronous signals to appropriate
192 -- exceptions. Make sure that the handler isn't interrupted by
193 -- another signal that might cause a scheduling event.
194
195 Signal_Action.sa_handler := GNAT_Error_Handler'Address;
196 Signal_Action.sa_flags := SA_ONSTACK;
197 Result := sigemptyset (Mask'Unchecked_Access);
198 Signal_Action.sa_mask := Mask;
199
200 Result := sigaction
201 (Signal (SIGFPE), Signal_Action'Unchecked_Access, null);
202
203 Result := sigaction
204 (Signal (SIGILL), Signal_Action'Unchecked_Access, null);
205
206 Result := sigaction
207 (Signal (SIGSEGV), Signal_Action'Unchecked_Access, null);
208
209 Result := sigaction
210 (Signal (SIGBUS), Signal_Action'Unchecked_Access, null);
211 end Install_Handler;
212
213 ------------------------
214 -- Runtime_Initialize --
215 ------------------------
216
217 procedure Runtime_Initialize is
218 begin
219 Install_Handler;
220 end Runtime_Initialize;
221
222 ----------------------
223 -- Runtime_Finalize --
224 ----------------------
225
226 procedure Runtime_Finalize is
227 begin
228 null;
229 end Runtime_Finalize;
230 end System.Init;