gcc/ada/i-vthrea.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS               --
   4 --                                                                          --
   5 --                   I N T E R F A C E S . V T H R E A D S                  --
   6 --                                                                          --
   7 --                                  B o d y                                 --
   8 --                                                                          --
   9 --        Copyright (C) 2002-2003, 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 2,  or (at your option) any later ver- --
  14 -- sion. GNARL 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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNARL; see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNARL was developed by the GNARL team at Florida State University.       --
  30 -- Extensive contributions were provided by Ada Core Technologies, Inc.     --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 --  Implement APEX process registration for AE653
  35
  36 with Ada.Exceptions;                  use Ada.Exceptions;
  37 with Ada.Unchecked_Conversion;
  38
  39 with Interfaces.C;
  40
  41 with System.Secondary_Stack;
  42 with System.Soft_Links;
  43 with System.Task_Primitives.Ae_653;
  44 with System.Task_Primitives.Operations; use System.Task_Primitives.Operations;
  45 with System.Tasking;                    use System.Tasking;
  46 with System.Task_Info;
  47 with System.Tasking.Initialization;
  48
  49 package body Interfaces.Vthreads is
  50
  51    use System.OS_Interface;
  52
  53    -----------------------
  54    -- Local Subprograms --
  55    -----------------------
  56
  57    procedure Enter_Task (T : Task_ID; Thread : Thread_Id);
  58    --  Duplicate and generalize
  59    --  System.Task_Primitives.Operations.Enter_Task
  60
  61    procedure GNAT_Error_Handler (Sig : Signal);
  62    --  Signal handler for ARINC processes
  63
  64    procedure Init_Float;
  65    pragma Import (C, Init_Float, "__gnat_init_float");
  66    --  Properly initializes the FPU for PPC systems.
  67
  68    procedure Install_Handler;
  69    --  Install signal handlers for the calling ARINC process
  70
  71    function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID;
  72    --  Duplicate and generalize
  73    --  System.Task_Primitives.Operations.Register_Foreign_Thread
  74
  75    -----------------------------
  76    -- Install_Signal_Handlers --
  77    -----------------------------
  78
  79    function Install_Signal_Handlers return Interfaces.C.int is
  80    begin
  81       Install_Handler;
  82       Init_Float;
  83       return 0;
  84    end Install_Signal_Handlers;
  85
  86    ----------------------
  87    -- Register_Foreign --
  88    ----------------------
  89
  90    --  Create Ada task data structures for an ARINC process. All dynamic
  91    --  allocation of related data structures must be done via this routine.
  92
  93    function Register_Foreign (T : OSI.Thread_Id) return OSI.STATUS is
  94       use Interfaces.C;
  95       use System.Task_Primitives.Ae_653;
  96
  97       pragma Assert (taskVarGet (T, ATCB_Key_Addr) = ERROR);
  98       --  "T" is not yet registered
  99
 100       Result  : OSI.STATUS := taskIdVerify (T);
 101       Status  : OSI.STATUS := OK;
 102       Temp_Id : Task_ID;
 103
 104    begin
 105       if Result = OK then
 106          Status := taskVarGet (T, ATCB_Key_Addr);
 107
 108          --  Error of already registered
 109
 110          if Status /= ERROR then
 111             Result := ERROR;
 112
 113          else
 114             --  Create a TCB
 115
 116             declare
 117                --  Make sure the caller has a TCB, since it's possible to have
 118                --  pure C APEX processes that create ones calling Ada code
 119
 120                Caller : Task_ID;
 121
 122             begin
 123                Status := taskVarGet (taskIdSelf, ATCB_Key_Addr);
 124
 125                if Status = ERROR then
 126                   Caller := Register_Foreign_Thread (taskIdSelf);
 127                end if;
 128             end;
 129
 130             if taskIdSelf /= T then
 131                Temp_Id := Register_Foreign_Thread (T);
 132             end if;
 133
 134             Result := OK;
 135          end if;
 136       end if;
 137
 138       return Result;
 139    end Register_Foreign;
 140
 141    -------------------
 142    -- Reset_Foreign --
 143    -------------------
 144
 145    --  Reinitialize Ada task data structures. No dynamic allocation
 146    --  may occur via this routine.
 147
 148    function Reset_Foreign (T : Thread_Id) return STATUS is
 149       use Interfaces.C;
 150       use System.Secondary_Stack;
 151       use System.Task_Primitives.Ae_653;
 152       use type System.Address;
 153
 154       pragma Assert (taskVarGet (T, ATCB_Key_Addr) /= ERROR);
 155       --  "T" has already been registered
 156
 157       Result : STATUS := taskVarGet (T, ATCB_Key_Addr);
 158       function To_Address is new Ada.Unchecked_Conversion
 159         (Interfaces.C.int, System.Address);
 160
 161       pragma Assert (
 162                      To_Task_Id
 163                      (To_Address (Result)).Common.Compiler_Data.Sec_Stack_Addr
 164                        /= System.Null_Address);
 165       --  "T" already has a secondary stack
 166
 167    begin
 168       if  Result /= ERROR then
 169
 170          --  Just reset the secondary stack pointer.  The implementation here
 171          --  assumes that the fixed secondary stack implementation is used.
 172          --  If not, there will be a memory leak (along with allocation, which
 173          --  is prohibited for ARINC processes once the system enters "normal"
 174          --  mode).
 175
 176          SS_Init
 177            (To_Task_Id
 178               (To_Address (Result)).Common.Compiler_Data.Sec_Stack_Addr);
 179          Result := OK;
 180       end if;
 181
 182       return Result;
 183    end Reset_Foreign;
 184
 185    ------------------
 186    -- Setup_Thread --
 187    ------------------
 188
 189    function Setup_Thread return System.Address is
 190       Result : System.Address := System.Null_Address;
 191       Status : OSI.STATUS;
 192
 193    begin
 194       if Is_Valid_Task then
 195          Status := Reset_Foreign (taskIdSelf);
 196          Result :=
 197            To_Address (System.Task_Primitives.Operations.Self);
 198       else
 199          Status := Register_Foreign (taskIdSelf);
 200          Install_Handler;
 201          Init_Float;
 202          Result :=
 203            To_Address (System.Task_Primitives.Operations.Self);
 204       end if;
 205
 206       return Result;
 207    end Setup_Thread;
 208
 209    ----------------
 210    -- Enter_Task --
 211    ----------------
 212
 213    procedure Enter_Task (T : Task_ID; Thread : Thread_Id) is
 214       use System.Task_Primitives.Ae_653;
 215
 216    begin
 217       Set_Task_Thread (T, Thread);
 218    end Enter_Task;
 219
 220    ------------------------
 221    -- GNAT_Error_Handler --
 222    ------------------------
 223
 224    procedure GNAT_Error_Handler (Sig : Signal) is
 225       Mask   : aliased sigset_t;
 226       Result : int;
 227
 228    begin
 229       --  This code is the Ada replacement for init.c in the
 230       --  AE653 level B runtime.
 231
 232       --  VxWorks will always mask out the signal during the signal
 233       --  handler and will reenable it on a longjmp.  GNAT does not
 234       --  generate a longjmp to return from a signal handler so the
 235       --  signal will still be masked unless we unmask it.
 236
 237       Result := pthread_sigmask (SIG_SETMASK, null, Mask'Unchecked_Access);
 238       Result := sigdelset (Mask'Access, Sig);
 239       Result := pthread_sigmask (SIG_SETMASK, Mask'Unchecked_Access, null);
 240
 241       case Sig is
 242          when SIGFPE =>
 243             Raise_Exception (Constraint_Error'Identity, "SIGFPE");
 244          when SIGILL =>
 245             Raise_Exception (Constraint_Error'Identity, "SIGILL");
 246          when SIGSEGV =>
 247             Raise_Exception
 248               (Program_Error'Identity,
 249                "erroneous memory access");
 250          when SIGBUS =>
 251             --  SIGBUS indicates stack overflow when it occurs
 252             --  in an application domain (but not in the Core
 253             --  OS under AE653, or in the kernel domain under
 254             --  AE 1.1).
 255             Raise_Exception
 256               (Storage_Error'Identity,
 257                "stack overflow or SIGBUS");
 258          when others =>
 259             Raise_Exception (Program_Error'Identity, "unhandled signal");
 260       end case;
 261    end GNAT_Error_Handler;
 262
 263    ---------------------
 264    -- Install_Handler --
 265    ---------------------
 266
 267    procedure Install_Handler is
 268       Mask          : aliased sigset_t;
 269       Signal_Action : aliased struct_sigaction;
 270       Result        : Interfaces.C.int;
 271
 272    begin
 273       --  Set up signal handler to map synchronous signals to appropriate
 274       --  exceptions. Make sure that the handler isn't interrupted by
 275       --  another signal that might cause a scheduling event!
 276
 277       --  This code is the Ada replacement for init.c in the
 278       --  AE653 level B runtime.
 279       Signal_Action.sa_handler := GNAT_Error_Handler'Address;
 280       Signal_Action.sa_flags := SA_ONSTACK;
 281       Result := sigemptyset (Mask'Access);
 282       Signal_Action.sa_mask := Mask;
 283
 284       Result := sigaction
 285         (Signal (SIGFPE), Signal_Action'Unchecked_Access, null);
 286
 287       Result := sigaction
 288         (Signal (SIGILL), Signal_Action'Unchecked_Access, null);
 289
 290       Result := sigaction
 291         (Signal (SIGSEGV), Signal_Action'Unchecked_Access, null);
 292
 293       Result := sigaction
 294         (Signal (SIGBUS), Signal_Action'Unchecked_Access, null);
 295
 296    end Install_Handler;
 297
 298    -----------------------------
 299    -- Register_Foreign_Thread --
 300    -----------------------------
 301
 302    Foreign_Task_Elaborated : aliased Boolean := True;
 303
 304    function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID is
 305       pragma Assert (Thread = taskIdSelf or else Is_Valid_Task);
 306       --  Ensure that allocation will work
 307
 308       Local_ATCB : aliased Ada_Task_Control_Block (0);
 309       New_Id    : Task_ID;
 310       Succeeded  : Boolean;
 311
 312       use type Interfaces.C.unsigned;
 313       use type System.Address;
 314       use System.Task_Info;
 315       use System.Task_Primitives.Ae_653;
 316
 317    begin
 318       if taskIdSelf = Thread then
 319          declare
 320             Self : Task_ID := Local_ATCB'Unchecked_Access;
 321             --  Temporarily record this as the Task_ID for the thread
 322
 323          begin
 324             Set_Current_Priority (Self, System.Priority'First);
 325             Set_Task_Thread (Self, Thread);
 326          end;
 327       end if;
 328
 329       pragma Assert (Is_Valid_Task);
 330       --  It is now safe to use an allocator for the real TCB
 331
 332       New_Id := new Ada_Task_Control_Block (0);
 333
 334       --  Finish initialization
 335
 336       System.Tasking.Initialize_ATCB
 337         (New_Id, null, System.Null_Address, Null_Task,
 338          Foreign_Task_Elaborated'Access,
 339          System.Priority'First,
 340          System.Task_Info.Unspecified_Task_Info, 0, New_Id,
 341          Succeeded);
 342       pragma Assert (Succeeded);
 343
 344       New_Id.Master_of_Task := 0;
 345       New_Id.Master_Within := New_Id.Master_of_Task + 1;
 346
 347       for L in New_Id.Entry_Calls'Range loop
 348          New_Id.Entry_Calls (L).Self := New_Id;
 349          New_Id.Entry_Calls (L).Level := L;
 350       end loop;
 351
 352       New_Id.Common.State := Runnable;
 353       New_Id.Awake_Count := 1;
 354
 355       --  Since this is not an ordinary Ada task, we will start out undeferred
 356
 357       New_Id.Deferral_Level := 0;
 358
 359       System.Soft_Links.Create_TSD (New_Id.Common.Compiler_Data);
 360
 361       --  Allocate a fixed secondary stack
 362
 363       pragma Assert
 364         (New_Id.Common.Compiler_Data.Sec_Stack_Addr = System.Null_Address);
 365       System.Secondary_Stack.SS_Init
 366         (New_Id.Common.Compiler_Data.Sec_Stack_Addr);
 367
 368       Enter_Task (New_Id, Thread);
 369
 370       return New_Id;
 371    end Register_Foreign_Thread;
 372
 373    --  Force use of tasking versions of secondary stack routines:
 374
 375    procedure Force_Closure renames
 376      System.Tasking.Initialization.Defer_Abortion;
 377    pragma Unreferenced (Force_Closure);
 378
 379 --  Package elaboration code
 380
 381 begin
 382    --  Register the exported routines with the vThreads ARINC API
 383
 384    procCreateHookAdd (Register_Foreign'Access);
 385    procStartHookAdd (Reset_Foreign'Access);
 386 end Interfaces.Vthreads;