path: root/gcc/ada/5zintman.adb

------------------------------------------------------------------------------
--                                                                          --
--                GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS               --
--                                                                          --
--           S Y S T E M . I N T E R R U P T _ M A N A G E M E N T          --
--                                                                          --
--                                  B o d y                                 --
--                                                                          --
--                             $Revision: 1.11 $
--                                                                          --
--             Copyright (C) 1991-2001 Florida State University             --
--                                                                          --
-- GNARL is free software; you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNARL; see file COPYING.  If not, write --
-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, USA.                                                      --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- GNARL was developed by the GNARL team at Florida State University. It is --
-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
-- State University (http://www.gnat.com).                                  --
--                                                                          --
------------------------------------------------------------------------------

--  This is the VxWorks version of this package.

--  It is likely to need tailoring to fit each operating system
--  and machine architecture.

--  PLEASE DO NOT add any dependences on other packages.
--  This package is designed to work with or without tasking support.

--  See the other warnings in the package specification before making
--  any modifications to this file.

--  Make a careful study of all signals available under the OS,
--  to see which need to be reserved, kept always unmasked,
--  or kept always unmasked.
--  Be on the lookout for special signals that
--  may be used by the thread library.

with Interfaces.C;
--  used for int and other types

with System.Error_Reporting;
pragma Warnings (Off, System.Error_Reporting);
--  used for Shutdown

with System.OS_Interface;
--  used for various Constants, Signal and types

with Unchecked_Conversion;

package body System.Interrupt_Management is

   use Interfaces.C;
   use System.Error_Reporting;
   use System.OS_Interface;

   function To_Isr is new Unchecked_Conversion (Long_Integer, isr_address);

   type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID;
   Exception_Interrupts : constant Interrupt_List :=
     (SIGFPE, SIGILL, SIGSEGV, SIGBUS);

   --  Keep these variables global so that they are initialized only once.

   Exception_Action : aliased struct_sigaction;
   Default_Action : aliased struct_sigaction;

   --  ????? Use these horrible imports here to solve elaboration order
   --  problems.

   type Task_Id is access all Integer;

   Interrupt_ID_Map : array (Interrupt_ID) of Task_Id;
   pragma Import (Ada, Interrupt_ID_Map,
     "system__task_primitives__interrupt_operations__interrupt_id_map");

   ----------------------
   -- Notify_Exception --
   ----------------------

   procedure Notify_Exception (signo : Signal);
   --  Identify the Ada exception to be raised using
   --  the information when the system received a synchronous signal.

   procedure Notify_Exception (signo : Signal) is
      Mask   : aliased sigset_t;
      Result : Interfaces.C.int;
      My_Id  : pthread_t;
   begin
      --  VxWorks will always mask out the signal during the signal
      --  handler and will reenable it on a longjmp.  GNAT does
      --  not generate a longjmp to return from a signal handler
      --  so the signal will still be masked unless we unmask it.
      Result := pthread_sigmask (SIG_SETMASK, null, Mask'Unchecked_Access);
      Result := sigdelset (Mask'Access, signo);
      Result := pthread_sigmask (SIG_SETMASK, Mask'Unchecked_Access, null);

      --  VxWorks will suspend the task when it gets a hardware
      --  exception.  We take the liberty of resuming the task
      --  for the application.
      My_Id := taskIdSelf;
      if taskIsSuspended (My_Id) /= 0 then
         Result := taskResume (My_Id);
      end if;

      --  As long as we are using a longjmp to return control to the
      --  exception handler on the runtime stack, we are safe. The original
      --  signal mask (the one we had before coming into this signal catching
      --  function) will be restored by the longjmp. Therefore, raising
      --  an exception in this handler should be a safe operation.

      --  Check that treatment of exception propagation here
      --  is consistent with treatment of the abort signal in
      --  System.Task_Primitives.Operations.

      --  How can SIGSEGV be split into constraint and storage errors?
      --  What should SIGILL really raise ? Some implementations have
      --  codes for different types of SIGILL and some raise Storage_Error.
      --  What causes SIGBUS and should it be caught?
      --  Peter Burwood

      case signo is
         when SIGFPE =>
            raise Constraint_Error;
         when SIGILL =>
            raise Constraint_Error;
         when SIGSEGV =>
            raise Program_Error;
         when SIGBUS =>
            raise Program_Error;
         when others =>
            pragma Assert (Shutdown ("Unexpected signal"));
            null;
      end case;
   end Notify_Exception;

   -------------------
   -- Notify_Signal --
   -------------------

   --  VxWorks needs a special casing here. Each VxWorks task has a completely
   --  separate signal handling, so the usual signal masking can't work.
   --  This idea is to handle all the signals in all the tasks, and when
   --  such a signal occurs, redirect it to the dedicated task (if any) or
   --  reraise it.

   procedure Notify_Signal (signo : Signal);

   procedure Notify_Signal (signo : Signal) is
      Mask    : aliased sigset_t;
      Result  : Interfaces.C.int;
      My_Id   : pthread_t;
      old_isr : isr_address;

      function Get_Thread_Id (T : Task_Id) return pthread_t;
      pragma Import (Ada, Get_Thread_Id,
        "system__task_primitives__operations__get_thread_id");

   begin
      --  VxWorks will always mask out the signal during the signal
      --  handler and will reenable it on a longjmp.  GNAT does
      --  not generate a longjmp to return from a signal handler
      --  so the signal will still be masked unless we unmask it.
      Result := pthread_sigmask (SIG_SETMASK, null, Mask'Unchecked_Access);
      Result := sigdelset (Mask'Access, signo);
      Result := pthread_sigmask (SIG_SETMASK, Mask'Unchecked_Access, null);

      --  VxWorks will suspend the task when it gets a hardware
      --  exception.  We take the liberty of resuming the task
      --  for the application.
      My_Id := taskIdSelf;
      if taskIsSuspended (My_Id) /= 0 then
         Result := taskResume (My_Id);
      end if;

      --  ??? Need a lock around this, in case the handler is detached
      --  between the two following statements.

      if Interrupt_ID_Map (Interrupt_ID (signo)) /= null then
         Result :=
           kill (Get_Thread_Id (Interrupt_ID_Map (Interrupt_ID (signo))),
             Signal (signo));
      else
         old_isr := c_signal (signo, To_Isr (SIG_DFL));
         Result := kill (My_Id, Signal (signo));
      end if;
   end Notify_Signal;

   ---------------------------
   -- Initialize_Interrupts --
   ---------------------------

   --  Since there is no signal inheritance between VxWorks tasks, we need
   --  to initialize signal handling in each task.

   procedure Initialize_Interrupts is
      old_act : aliased struct_sigaction;
      Result  : Interfaces.C.int;

   begin
      for J in Interrupt_ID'First + 1 .. Interrupt_ID'Last loop
         if J /= Abort_Task_Interrupt then
            Result := sigaction (Signal (J), Default_Action'Access,
              old_act'Unchecked_Access);
            pragma Assert (Result = 0);
         end if;
      end loop;

      for J in Exception_Interrupts'Range loop
         Keep_Unmasked (Exception_Interrupts (J)) := True;
         Result :=
           sigaction
             (Signal (Exception_Interrupts (J)), Exception_Action'Access,
              old_act'Unchecked_Access);
         pragma Assert (Result = 0);
      end loop;
   end Initialize_Interrupts;

begin
   declare
      mask         : aliased sigset_t;
      default_mask : aliased sigset_t;
      Result       : Interfaces.C.int;

   begin
      --  The VxWorks POSIX threads library currently needs initialization.
      --  We wish it could be in System.OS_Interface, but that would
      --  cause an elaboration problem.

      pthread_init;

      Abort_Task_Interrupt := SIGABRT;
      --  Change this if you want to use another signal for task abort.
      --  SIGTERM might be a good one.

      Exception_Action.sa_handler := Notify_Exception'Address;
      Default_Action.sa_handler   := Notify_Signal'Address;

      Exception_Action.sa_flags := SA_SIGINFO + SA_ONSTACK;
      Default_Action.sa_flags := SA_SIGINFO + SA_ONSTACK;
      --  Send us extra signal information (SA_SIGINFO) on the
      --  stack (SA_ONSTACK).
      --  There is no SA_NODEFER in VxWorks.  The signal mask is
      --  restored after a longjmp so the SA_NODEFER option is
      --  not needed.  - Dan Eischen

      Result := sigemptyset (mask'Access);
      pragma Assert (Result = 0);
      Result := sigemptyset (default_mask'Access);
      pragma Assert (Result = 0);

      for J in Interrupt_ID'First + 1 .. Interrupt_ID'Last loop
         Result := sigaddset (default_mask'Access, Signal (J));
         pragma Assert (Result = 0);
      end loop;

      for J in Exception_Interrupts'Range loop
         Result := sigaddset (mask'Access, Signal (Exception_Interrupts (J)));
         pragma Assert (Result = 0);
         Result :=
           sigdelset (default_mask'Access, Signal (Exception_Interrupts (J)));
         pragma Assert (Result = 0);
      end loop;

      Exception_Action.sa_mask := mask;
      Default_Action.sa_mask := default_mask;

      --  Initialize_Interrupts is called for each task in Enter_Task

      Keep_Unmasked (Abort_Task_Interrupt) := True;

      Reserve := Reserve or Keep_Unmasked or Keep_Masked;

      Reserve (0) := True;
      --  We do not have Signal 0 in reality. We just use this value
      --  to identify non-existent signals (see s-intnam.ads). Therefore,
      --  Signal 0 should not be used in all signal related operations hence
      --  mark it as reserved.
   end;
end System.Interrupt_Management;