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-2018, 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
34pragma 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
39with System.OS_Versions; use System.OS_Versions;
40
41package 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
238begin
239   --  Initialize run-time library
240
241   Init_RTS;
242end System.Threads;
243