Subversion Repositories openrisc

------------------------------------------------------------------------------

--                                                                          --

--                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --

--                                                                          --

--                     S Y S T E M . I N T E R R U P T S                    --

--                                                                          --

--                                  B o d y                                 --

--                                                                          --

--         Copyright (C) 1992-2009, Free Software Foundation, Inc.          --

--                                                                          --

-- 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 3,  or (at your option) any later ver- --

-- sion.  GNAT 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.                                     --

--                                                                          --

-- As a special exception under Section 7 of GPL version 3, you are granted --

-- additional permissions described in the GCC Runtime Library Exception,   --

-- version 3.1, as published by the Free Software Foundation.               --

--                                                                          --

-- You should have received a copy of the GNU General Public License and    --

-- a copy of the GCC Runtime Library Exception along with this program;     --

-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --

-- <http://www.gnu.org/licenses/>.                                          --

--                                                                          --

-- GNARL was developed by the GNARL team at Florida State University.       --

-- Extensive contributions were provided by Ada Core Technologies, Inc.     --

--                                                                          --

------------------------------------------------------------------------------

--  Invariants:

--  All user-handleable interrupts are masked at all times in all

--  tasks/threads except possibly for the Interrupt_Manager task.

--  When a user task wants to have the effect of masking/unmasking an

--  interrupt, it must call Block_Interrupt/Unblock_Interrupt, which

--  will have the effect of unmasking/masking the interrupt in the

--  Interrupt_Manager task.

--  Note : Direct calls to sigaction, sigprocmask, pthread_sigsetmask or any

--  other low-level interface that changes the interrupt action or

--  interrupt mask needs a careful thought.

--  One may achieve the effect of system calls first masking RTS blocked

--  (by calling Block_Interrupt) for the interrupt under consideration.

--  This will make all the tasks in RTS blocked for the Interrupt.

--  Once we associate a Server_Task with an interrupt, the task never

--  goes away, and we never remove the association.

--  There is no more than one interrupt per Server_Task and no more than

--  one Server_Task per interrupt.

with Ada.Task_Identification;

with System.Task_Primitives;

with System.Interrupt_Management;

with System.Interrupt_Management.Operations;

pragma Elaborate_All (System.Interrupt_Management.Operations);

with System.Task_Primitives.Operations;

with System.Task_Primitives.Interrupt_Operations;

with System.Storage_Elements;

with System.Tasking.Utilities;

with System.Tasking.Rendezvous;

pragma Elaborate_All (System.Tasking.Rendezvous);

with System.Tasking.Initialization;

with System.Parameters;

with Ada.Unchecked_Conversion;

package body System.Interrupts is

   use Parameters;

   use Tasking;

   package POP renames System.Task_Primitives.Operations;

   package PIO renames System.Task_Primitives.Interrupt_Operations;

   package IMNG renames System.Interrupt_Management;

   package IMOP renames System.Interrupt_Management.Operations;

   function To_System is new Ada.Unchecked_Conversion

     (Ada.Task_Identification.Task_Id, Task_Id);

   -----------------

   -- Local Tasks --

   -----------------

   --  WARNING: System.Tasking.Stages performs calls to this task with

   --  low-level constructs. Do not change this spec without synchronizing it.

   task Interrupt_Manager is

      entry Detach_Interrupt_Entries (T : Task_Id);

      entry Initialize (Mask : IMNG.Interrupt_Mask);

      entry Attach_Handler

        (New_Handler : Parameterless_Handler;

         Interrupt   : Interrupt_ID;

         Static      : Boolean;

         Restoration : Boolean := False);

      entry Exchange_Handler

        (Old_Handler : out Parameterless_Handler;

         New_Handler : Parameterless_Handler;

         Interrupt   : Interrupt_ID;

         Static      : Boolean);

      entry Detach_Handler

        (Interrupt   : Interrupt_ID;

         Static      : Boolean);

      entry Bind_Interrupt_To_Entry

        (T         : Task_Id;

         E         : Task_Entry_Index;

         Interrupt : Interrupt_ID);

      entry Block_Interrupt (Interrupt : Interrupt_ID);

      entry Unblock_Interrupt (Interrupt : Interrupt_ID);

      entry Ignore_Interrupt (Interrupt : Interrupt_ID);

      entry Unignore_Interrupt (Interrupt : Interrupt_ID);

      pragma Interrupt_Priority (System.Interrupt_Priority'Last);

   end Interrupt_Manager;

   task type Server_Task (Interrupt : Interrupt_ID) is

      pragma Priority (System.Interrupt_Priority'Last);

      --  Note: the above pragma Priority is strictly speaking improper since

      --  it is outside the range of allowed priorities, but the compiler

      --  treats system units specially and does not apply this range checking

      --  rule to system units.

   end Server_Task;

   type Server_Task_Access is access Server_Task;

   -------------------------------

   -- Local Types and Variables --

   -------------------------------

   type Entry_Assoc is record

      T : Task_Id;

      E : Task_Entry_Index;

   end record;

   type Handler_Assoc is record

      H      : Parameterless_Handler;

      Static : Boolean;   --  Indicates static binding;

   end record;

   User_Handler : array (Interrupt_ID'Range) of Handler_Assoc :=

                    (others => (null, Static => False));

   pragma Volatile_Components (User_Handler);

   --  Holds the protected procedure handler (if any) and its Static

   --  information for each interrupt. A handler is a Static one if it is

   --  specified through the pragma Attach_Handler. Attach_Handler. Otherwise,

   --  not static)

   User_Entry : array (Interrupt_ID'Range) of Entry_Assoc :=

                  (others => (T => Null_Task, E => Null_Task_Entry));

   pragma Volatile_Components (User_Entry);

   --  Holds the task and entry index (if any) for each interrupt

   Blocked : array (Interrupt_ID'Range) of Boolean := (others => False);

   pragma Atomic_Components (Blocked);

   --  True iff the corresponding interrupt is blocked in the process level

   Ignored : array (Interrupt_ID'Range) of Boolean := (others => False);

   pragma Atomic_Components (Ignored);

   --  True iff the corresponding interrupt is blocked in the process level

   Last_Unblocker :

     array (Interrupt_ID'Range) of Task_Id := (others => Null_Task);

   pragma Atomic_Components (Last_Unblocker);

   --  Holds the ID of the last Task which Unblocked this Interrupt. It

   --  contains Null_Task if no tasks have ever requested the Unblocking

   --  operation or the Interrupt is currently Blocked.

   Server_ID : array (Interrupt_ID'Range) of Task_Id :=

                 (others => Null_Task);

   pragma Atomic_Components (Server_ID);

   --  Holds the Task_Id of the Server_Task for each interrupt. Task_Id is

   --  needed to accomplish locking per Interrupt base. Also is needed to

   --  decide whether to create a new Server_Task.

   --  Type and Head, Tail of the list containing Registered Interrupt

   --  Handlers. These definitions are used to register the handlers

   --  specified by the pragma Interrupt_Handler.

   type Registered_Handler;

   type R_Link is access all Registered_Handler;

   type Registered_Handler is record

      H    : System.Address := System.Null_Address;

      Next : R_Link := null;

   end record;

   Registered_Handler_Head : R_Link := null;

   Registered_Handler_Tail : R_Link := null;

   Access_Hold : Server_Task_Access;

   --  Variable used to allocate Server_Task using "new"

   -----------------------

   -- Local Subprograms --

   -----------------------

   function Is_Registered (Handler : Parameterless_Handler) return Boolean;

   --  See if the Handler has been "pragma"ed using Interrupt_Handler. Always

   --  consider a null handler as registered.

   --------------------

   -- Attach_Handler --

   --------------------

   --  Calling this procedure with New_Handler = null and Static = True means

   --  we want to detach the current handler regardless of the previous

   --  handler's binding status (i.e. do not care if it is a dynamic or static

   --  handler).

   --  This option is needed so that during the finalization of a PO, we can

   --  detach handlers attached through pragma Attach_Handler.

   procedure Attach_Handler

     (New_Handler : Parameterless_Handler;

      Interrupt   : Interrupt_ID;

      Static      : Boolean := False)

   is

   begin

      if Is_Reserved (Interrupt) then

         raise Program_Error with

           "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";

      end if;

      Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static);

   end Attach_Handler;

   -----------------------------

   -- Bind_Interrupt_To_Entry --

   -----------------------------

   --  This procedure raises a Program_Error if it tries to bind an interrupt

   --  to which an Entry or a Procedure is already bound.

   procedure Bind_Interrupt_To_Entry

     (T       : Task_Id;

      E       : Task_Entry_Index;

      Int_Ref : System.Address)

   is

      Interrupt   : constant Interrupt_ID :=

                      Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));

   begin

      if Is_Reserved (Interrupt) then

         raise Program_Error with

           "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";

      end if;

      Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt);

   end Bind_Interrupt_To_Entry;

   ---------------------

   -- Block_Interrupt --

   ---------------------

   procedure Block_Interrupt (Interrupt : Interrupt_ID) is

   begin

      if Is_Reserved (Interrupt) then

         raise Program_Error with

           "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";

      end if;

      Interrupt_Manager.Block_Interrupt (Interrupt);

   end Block_Interrupt;

   ---------------------

   -- Current_Handler --

   ---------------------

   function Current_Handler

     (Interrupt : Interrupt_ID) return Parameterless_Handler

   is

   begin

      if Is_Reserved (Interrupt) then

         raise Program_Error with

           "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";

      end if;

      --  ??? Since Parameterless_Handler is not Atomic, the current

      --  implementation is wrong. We need a new service in Interrupt_Manager

      --  to ensure atomicity.

      return User_Handler (Interrupt).H;

   end Current_Handler;

   --------------------

   -- Detach_Handler --

   --------------------

   --  Calling this procedure with Static = True means we want to Detach the

   --  current handler regardless of the previous handler's binding status

   --  (i.e. do not care if it is a dynamic or static handler).

   --  This option is needed so that during the finalization of a PO, we can

   --  detach handlers attached through pragma Attach_Handler.

   procedure Detach_Handler

     (Interrupt : Interrupt_ID;

      Static    : Boolean := False)

   is

   begin

      if Is_Reserved (Interrupt) then

         raise Program_Error with

           "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";

      end if;

      Interrupt_Manager.Detach_Handler (Interrupt, Static);

   end Detach_Handler;

   ------------------------------

   -- Detach_Interrupt_Entries --

   ------------------------------

   procedure Detach_Interrupt_Entries (T : Task_Id) is

   begin

      Interrupt_Manager.Detach_Interrupt_Entries (T);

   end Detach_Interrupt_Entries;

   ----------------------

   -- Exchange_Handler --

   ----------------------

   --  Calling this procedure with New_Handler = null and Static = True means

   --  we want to detach the current handler regardless of the previous

   --  handler's binding status (i.e. do not care if it is a dynamic or static

   --  handler).

   --  This option is needed so that during the finalization of a PO, we can

   --  detach handlers attached through pragma Attach_Handler.

   procedure Exchange_Handler

     (Old_Handler : out Parameterless_Handler;

      New_Handler : Parameterless_Handler;

      Interrupt   : Interrupt_ID;

      Static      : Boolean := False)

   is

   begin

      if Is_Reserved (Interrupt) then

         raise Program_Error with

           "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";

      end if;

      Interrupt_Manager.Exchange_Handler

        (Old_Handler, New_Handler, Interrupt, Static);

   end Exchange_Handler;

   --------------

   -- Finalize --

   --------------

   procedure Finalize (Object : in out Static_Interrupt_Protection) is

      function State

        (Int : System.Interrupt_Management.Interrupt_ID) return Character;

      pragma Import (C, State, "__gnat_get_interrupt_state");

      --  Get interrupt state for interrupt number Int. Defined in init.c

      Default : constant Character := 's';

      --    's'   Interrupt_State pragma set state to System (use "default"

      --           system handler)

   begin

      --  ??? loop to be executed only when we're not doing library level

      --  finalization, since in this case all interrupt tasks are gone.

      --  If the Abort_Task signal is set to system, it means that we cannot

      --  reset interrupt handlers since this would require sending the abort

      --  signal to the Server_Task

      if not Interrupt_Manager'Terminated

        and then State (System.Interrupt_Management.Abort_Task_Interrupt)

                  /= Default

      then

         for N in reverse Object.Previous_Handlers'Range loop

            Interrupt_Manager.Attach_Handler

              (New_Handler => Object.Previous_Handlers (N).Handler,

               Interrupt   => Object.Previous_Handlers (N).Interrupt,

               Static      => Object.Previous_Handlers (N).Static,

               Restoration => True);

         end loop;

      end if;

      Tasking.Protected_Objects.Entries.Finalize

        (Tasking.Protected_Objects.Entries.Protection_Entries (Object));

   end Finalize;

   -------------------------------------

   -- Has_Interrupt_Or_Attach_Handler --

   -------------------------------------

   --  Need comments as to why these always return True ???

   function Has_Interrupt_Or_Attach_Handler

     (Object : access Dynamic_Interrupt_Protection) return Boolean

   is

      pragma Unreferenced (Object);

   begin

      return True;

   end Has_Interrupt_Or_Attach_Handler;

   function Has_Interrupt_Or_Attach_Handler

     (Object : access Static_Interrupt_Protection) return Boolean

   is

      pragma Unreferenced (Object);

   begin

      return True;

   end Has_Interrupt_Or_Attach_Handler;

   ----------------------

   -- Ignore_Interrupt --

   ----------------------

   procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is

   begin

      if Is_Reserved (Interrupt) then

         raise Program_Error with

           "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";

      end if;

      Interrupt_Manager.Ignore_Interrupt (Interrupt);

   end Ignore_Interrupt;

   ----------------------

   -- Install_Handlers --

   ----------------------

   procedure Install_Handlers

     (Object       : access Static_Interrupt_Protection;

      New_Handlers : New_Handler_Array)

   is

   begin

      for N in New_Handlers'Range loop

         --  We need a lock around this ???

         Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt;

         Object.Previous_Handlers (N).Static    := User_Handler

           (New_Handlers (N).Interrupt).Static;

         --  We call Exchange_Handler and not directly Interrupt_Manager.

         --  Exchange_Handler so we get the Is_Reserved check.

         Exchange_Handler

           (Old_Handler => Object.Previous_Handlers (N).Handler,

            New_Handler => New_Handlers (N).Handler,

            Interrupt   => New_Handlers (N).Interrupt,

            Static      => True);

      end loop;

   end Install_Handlers;

   ---------------------------------

   -- Install_Restricted_Handlers --

   ---------------------------------

   procedure Install_Restricted_Handlers (Handlers : New_Handler_Array) is

   begin

      for N in Handlers'Range loop

         Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True);

      end loop;

   end Install_Restricted_Handlers;

   ----------------

   -- Is_Blocked --

   ----------------

   function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is

   begin

      if Is_Reserved (Interrupt) then

         raise Program_Error with

           "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";

      end if;

      return Blocked (Interrupt);

   end Is_Blocked;

   -----------------------

   -- Is_Entry_Attached --

   -----------------------

   function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is

   begin

      if Is_Reserved (Interrupt) then

         raise Program_Error with

           "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";

      end if;

      return User_Entry (Interrupt).T /= Null_Task;

   end Is_Entry_Attached;

   -------------------------

   -- Is_Handler_Attached --

   -------------------------

   function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is

   begin

      if Is_Reserved (Interrupt) then

         raise Program_Error with

           "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";

      end if;

      return User_Handler (Interrupt).H /= null;

   end Is_Handler_Attached;

   ----------------

   -- Is_Ignored --

   ----------------

   function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is

   begin

      if Is_Reserved (Interrupt) then

         raise Program_Error with

           "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";

      end if;

      return Ignored (Interrupt);

   end Is_Ignored;

   -------------------

   -- Is_Registered --

   -------------------

   function Is_Registered (Handler : Parameterless_Handler) return Boolean is

      type Fat_Ptr is record

         Object_Addr  : System.Address;

         Handler_Addr : System.Address;

      end record;

      function To_Fat_Ptr is new Ada.Unchecked_Conversion

        (Parameterless_Handler, Fat_Ptr);

      Ptr : R_Link;

      Fat : Fat_Ptr;

   begin

      if Handler = null then

         return True;

      end if;

      Fat := To_Fat_Ptr (Handler);

      Ptr := Registered_Handler_Head;

      while Ptr /= null loop

         if Ptr.H = Fat.Handler_Addr then

            return True;

         end if;

         Ptr := Ptr.Next;

      end loop;

      return False;

   end Is_Registered;

   -----------------

   -- Is_Reserved --

   -----------------

   function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is

   begin

      return IMNG.Reserve (IMNG.Interrupt_ID (Interrupt));

   end Is_Reserved;

   ---------------

   -- Reference --

   ---------------

   function Reference (Interrupt : Interrupt_ID) return System.Address is

   begin

      if Is_Reserved (Interrupt) then

         raise Program_Error with

           "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";

      end if;

      return Storage_Elements.To_Address

        (Storage_Elements.Integer_Address (Interrupt));

   end Reference;

   ---------------------------------

   -- Register_Interrupt_Handler  --

   ---------------------------------

   procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is

      New_Node_Ptr : R_Link;

   begin

      --  This routine registers the Handler as usable for Dynamic Interrupt

      --  Handler. Routines attaching and detaching Handler dynamically should

      --  first consult if the Handler is registered. A Program Error should

      --  be raised if it is not registered.

      --  The pragma Interrupt_Handler can only appear in the library level PO

      --  definition and instantiation. Therefore, we do not need to implement

      --  Unregistering operation. Neither we need to protect the queue

      --  structure using a Lock.

      pragma Assert (Handler_Addr /= System.Null_Address);

      New_Node_Ptr := new Registered_Handler;

      New_Node_Ptr.H := Handler_Addr;

      if Registered_Handler_Head = null then

         Registered_Handler_Head := New_Node_Ptr;

         Registered_Handler_Tail := New_Node_Ptr;

      else

         Registered_Handler_Tail.Next := New_Node_Ptr;

         Registered_Handler_Tail := New_Node_Ptr;

      end if;

   end Register_Interrupt_Handler;

   -----------------------

   -- Unblock_Interrupt --

   -----------------------

   procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is

   begin

      if Is_Reserved (Interrupt) then

         raise Program_Error with

           "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";

      end if;

      Interrupt_Manager.Unblock_Interrupt (Interrupt);

   end Unblock_Interrupt;

   ------------------

   -- Unblocked_By --

   ------------------

   function Unblocked_By

     (Interrupt : Interrupt_ID) return System.Tasking.Task_Id

   is

   begin

      if Is_Reserved (Interrupt) then

         raise Program_Error with

           "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";

      end if;

      return Last_Unblocker (Interrupt);

   end Unblocked_By;

   ------------------------

   -- Unignore_Interrupt --

   ------------------------

   procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is

   begin

      if Is_Reserved (Interrupt) then

         raise Program_Error with

           "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";

      end if;

      Interrupt_Manager.Unignore_Interrupt (Interrupt);

   end Unignore_Interrupt;

   -----------------------

   -- Interrupt_Manager --

   -----------------------

   task body Interrupt_Manager is

      ---------------------

      -- Local Variables --

      ---------------------

      Intwait_Mask  : aliased IMNG.Interrupt_Mask;

      Ret_Interrupt : Interrupt_ID;

      Old_Mask      : aliased IMNG.Interrupt_Mask;

      Old_Handler   : Parameterless_Handler;

      --------------------

      -- Local Routines --

      --------------------

      procedure Bind_Handler (Interrupt : Interrupt_ID);

      --  This procedure does not do anything if the Interrupt is blocked.

      --  Otherwise, we have to interrupt Server_Task for status change through

      --  Wakeup interrupt.

      procedure Unbind_Handler (Interrupt : Interrupt_ID);

      --  This procedure does not do anything if the Interrupt is blocked.

      --  Otherwise, we have to interrupt Server_Task for status change

      --  through abort interrupt.

      procedure Unprotected_Exchange_Handler

        (Old_Handler : out Parameterless_Handler;

         New_Handler : Parameterless_Handler;

         Interrupt   : Interrupt_ID;

         Static      : Boolean;

         Restoration : Boolean := False);

      procedure Unprotected_Detach_Handler

        (Interrupt   : Interrupt_ID;

         Static      : Boolean);

      ------------------

      -- Bind_Handler --

      ------------------

      procedure Bind_Handler (Interrupt : Interrupt_ID) is

      begin

         if not Blocked (Interrupt) then

            --  Mask this task for the given Interrupt so that all tasks

            --  are masked for the Interrupt and the actual delivery of the

            --  Interrupt will be caught using "sigwait" by the

            --  corresponding Server_Task.

            IMOP.Thread_Block_Interrupt (IMNG.Interrupt_ID (Interrupt));

            --  We have installed a Handler or an Entry before we called

            --  this procedure. If the Handler Task is waiting to be awakened,

            --  do it here. Otherwise, the interrupt will be discarded.

            POP.Wakeup (Server_ID (Interrupt), Interrupt_Server_Idle_Sleep);

         end if;

      end Bind_Handler;

      --------------------

      -- Unbind_Handler --

      --------------------

      procedure Unbind_Handler (Interrupt : Interrupt_ID) is

         Server : System.Tasking.Task_Id;

      begin

         if not Blocked (Interrupt) then

            --  Currently, there is a Handler or an Entry attached and

            --  corresponding Server_Task is waiting on "sigwait."

            --  We have to wake up the Server_Task and make it

            --  wait on condition variable by sending an

            --  Abort_Task_Interrupt

            Server := Server_ID (Interrupt);

            case Server.Common.State is

               when Interrupt_Server_Idle_Sleep |

                    Interrupt_Server_Blocked_Interrupt_Sleep

               =>

                  POP.Wakeup (Server, Server.Common.State);

               when Interrupt_Server_Blocked_On_Event_Flag =>

                  POP.Abort_Task (Server);

                  --  Make sure corresponding Server_Task is out of its

                  --  own sigwait state.

                  Ret_Interrupt :=

                    Interrupt_ID (IMOP.Interrupt_Wait (Intwait_Mask'Access));

                  pragma Assert

                    (Ret_Interrupt = Interrupt_ID (IMNG.Abort_Task_Interrupt));

               when Runnable =>

                  null;

               when others =>

                  pragma Assert (False);

                  null;

            end case;

            IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt));