aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.2.1/gcc/ada/s-interr-sigaction.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.2.1/gcc/ada/s-interr-sigaction.adb')
-rw-r--r--gcc-4.2.1/gcc/ada/s-interr-sigaction.adb679
1 files changed, 679 insertions, 0 deletions
diff --git a/gcc-4.2.1/gcc/ada/s-interr-sigaction.adb b/gcc-4.2.1/gcc/ada/s-interr-sigaction.adb
new file mode 100644
index 000000000..4a1cd56ae
--- /dev/null
+++ b/gcc-4.2.1/gcc/ada/s-interr-sigaction.adb
@@ -0,0 +1,679 @@
+------------------------------------------------------------------------------
+-- --
+-- 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) 1998-2006, Free Software Fundation --
+-- --
+-- 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, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, 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. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the IRIX & NT version of this package
+
+with Ada.Task_Identification;
+-- used for Task_Id
+
+with Ada.Exceptions;
+-- used for Raise_Exception
+
+with System.Storage_Elements;
+-- used for To_Address
+-- To_Integer
+
+with System.Task_Primitives.Operations;
+-- used for Self
+-- Sleep
+-- Wakeup
+-- Write_Lock
+-- Unlock
+
+with System.Tasking.Utilities;
+-- used for Make_Independent
+
+with System.Tasking.Rendezvous;
+-- used for Call_Simple
+
+with System.Tasking.Initialization;
+-- used for Defer_Abort
+-- Undefer_Abort
+
+with System.Interrupt_Management;
+
+with System.Parameters;
+-- used for Single_Lock
+
+with Interfaces.C;
+-- used for int
+
+with Unchecked_Conversion;
+
+package body System.Interrupts is
+
+ use Parameters;
+ use Tasking;
+ use Ada.Exceptions;
+ use System.OS_Interface;
+ use Interfaces.C;
+
+ package STPO renames System.Task_Primitives.Operations;
+ package IMNG renames System.Interrupt_Management;
+
+ subtype int is Interfaces.C.int;
+
+ function To_System is new Unchecked_Conversion
+ (Ada.Task_Identification.Task_Id, Task_Id);
+
+ type Handler_Kind is (Unknown, Task_Entry, Protected_Procedure);
+
+ type Handler_Desc is record
+ Kind : Handler_Kind := Unknown;
+ T : Task_Id;
+ E : Task_Entry_Index;
+ H : Parameterless_Handler;
+ Static : Boolean := False;
+ end record;
+
+ task type Server_Task (Interrupt : Interrupt_ID) is
+ pragma Interrupt_Priority (System.Interrupt_Priority'Last);
+ end Server_Task;
+
+ type Server_Task_Access is access Server_Task;
+
+ Handlers : array (Interrupt_ID) of Task_Id;
+ Descriptors : array (Interrupt_ID) of Handler_Desc;
+ Interrupt_Count : array (Interrupt_ID) of Integer := (others => 0);
+
+ pragma Volatile_Components (Interrupt_Count);
+
+ procedure Attach_Handler
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean);
+ -- This internal procedure is needed to finalize protected objects
+ -- that contain interrupt handlers.
+
+ procedure Signal_Handler (Sig : Interrupt_ID);
+ -- This procedure is used to handle all the signals
+
+ -- 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.
+
+ --------------------------
+ -- Handler Registration --
+ --------------------------
+
+ 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_Handlers : R_Link := null;
+
+ 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.
+
+ type Handler_Ptr is access procedure (Sig : Interrupt_ID);
+
+ function TISR is new Unchecked_Conversion (Handler_Ptr, isr_address);
+
+ --------------------
+ -- Signal_Handler --
+ --------------------
+
+ procedure Signal_Handler (Sig : Interrupt_ID) is
+ Handler : Task_Id renames Handlers (Sig);
+
+ begin
+ if Intr_Attach_Reset and then
+ intr_attach (int (Sig), TISR (Signal_Handler'Access)) = FUNC_ERR
+ then
+ raise Program_Error;
+ end if;
+
+ if Handler /= null then
+ Interrupt_Count (Sig) := Interrupt_Count (Sig) + 1;
+ STPO.Wakeup (Handler, Interrupt_Server_Idle_Sleep);
+ end if;
+ end Signal_Handler;
+
+ -----------------
+ -- Is_Reserved --
+ -----------------
+
+ function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ return IMNG.Reserve (IMNG.Interrupt_ID (Interrupt));
+ end Is_Reserved;
+
+ -----------------------
+ -- Is_Entry_Attached --
+ -----------------------
+
+ function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ if Is_Reserved (Interrupt) then
+ Raise_Exception (Program_Error'Identity, "Interrupt" &
+ Interrupt_ID'Image (Interrupt) & " is reserved");
+ end if;
+
+ return Descriptors (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_Exception (Program_Error'Identity, "Interrupt" &
+ Interrupt_ID'Image (Interrupt) & " is reserved");
+ end if;
+
+ return Descriptors (Interrupt).Kind /= Unknown;
+ end Is_Handler_Attached;
+
+ ----------------
+ -- Is_Ignored --
+ ----------------
+
+ function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ raise Program_Error;
+ return False;
+ end Is_Ignored;
+
+ ------------------
+ -- Unblocked_By --
+ ------------------
+
+ function Unblocked_By (Interrupt : Interrupt_ID) return Task_Id is
+ begin
+ raise Program_Error;
+ return Null_Task;
+ end Unblocked_By;
+
+ ----------------------
+ -- Ignore_Interrupt --
+ ----------------------
+
+ procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ raise Program_Error;
+ end Ignore_Interrupt;
+
+ ------------------------
+ -- Unignore_Interrupt --
+ ------------------------
+
+ procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ raise Program_Error;
+ end Unignore_Interrupt;
+
+ -------------------------------------
+ -- Has_Interrupt_Or_Attach_Handler --
+ -------------------------------------
+
+ 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;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Static_Interrupt_Protection) is
+ begin
+ -- ??? loop to be executed only when we're not doing library level
+ -- finalization, since in this case all interrupt tasks are gone.
+
+ for N in reverse Object.Previous_Handlers'Range loop
+ 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;
+
+ Tasking.Protected_Objects.Entries.Finalize
+ (Tasking.Protected_Objects.Entries.Protection_Entries (Object));
+ end Finalize;
+
+ -------------------------------------
+ -- 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;
+
+ ----------------------
+ -- 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 := Descriptors
+ (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;
+
+ ---------------------
+ -- Current_Handler --
+ ---------------------
+
+ function Current_Handler
+ (Interrupt : Interrupt_ID) return Parameterless_Handler
+ is
+ begin
+ if Is_Reserved (Interrupt) then
+ raise Program_Error;
+ end if;
+
+ if Descriptors (Interrupt).Kind = Protected_Procedure then
+ return Descriptors (Interrupt).H;
+ else
+ return null;
+ end if;
+ end Current_Handler;
+
+ --------------------
+ -- Attach_Handler --
+ --------------------
+
+ procedure Attach_Handler
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean := False) is
+ begin
+ Attach_Handler (New_Handler, Interrupt, Static, False);
+ end Attach_Handler;
+
+ procedure Attach_Handler
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean)
+ is
+ New_Task : Server_Task_Access;
+
+ begin
+ if Is_Reserved (Interrupt) then
+ raise Program_Error;
+ end if;
+
+ if not Restoration and then not Static
+
+ -- Tries to overwrite a static Interrupt Handler with dynamic handle
+
+ and then
+ (Descriptors (Interrupt).Static
+
+ -- New handler not specified as an Interrupt Handler by a pragma
+
+ or else not Is_Registered (New_Handler))
+ then
+ Raise_Exception (Program_Error'Identity,
+ "Trying to overwrite a static Interrupt Handler with a " &
+ "dynamic Handler");
+ end if;
+
+ if Handlers (Interrupt) = null then
+ New_Task := new Server_Task (Interrupt);
+ Handlers (Interrupt) := To_System (New_Task.all'Identity);
+ end if;
+
+ if intr_attach (int (Interrupt),
+ TISR (Signal_Handler'Access)) = FUNC_ERR
+ then
+ raise Program_Error;
+ end if;
+
+ if New_Handler = null then
+
+ -- The null handler means we are detaching the handler
+
+ Descriptors (Interrupt) :=
+ (Kind => Unknown, T => null, E => 0, H => null, Static => False);
+
+ else
+ Descriptors (Interrupt).Kind := Protected_Procedure;
+ Descriptors (Interrupt).H := New_Handler;
+ Descriptors (Interrupt).Static := Static;
+ end if;
+ end Attach_Handler;
+
+ ----------------------
+ -- Exchange_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;
+ end if;
+
+ if Descriptors (Interrupt).Kind = Task_Entry then
+
+ -- In case we have an Interrupt Entry already installed.
+ -- raise a program error. (propagate it to the caller).
+
+ Raise_Exception (Program_Error'Identity,
+ "An interrupt is already installed");
+ end if;
+
+ Old_Handler := Current_Handler (Interrupt);
+ Attach_Handler (New_Handler, Interrupt, Static);
+ end Exchange_Handler;
+
+ --------------------
+ -- Detach_Handler --
+ --------------------
+
+ procedure Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean := False)
+ is
+ begin
+ if Is_Reserved (Interrupt) then
+ raise Program_Error;
+ end if;
+
+ if Descriptors (Interrupt).Kind = Task_Entry then
+ Raise_Exception (Program_Error'Identity,
+ "Trying to detach an Interrupt Entry");
+ end if;
+
+ if not Static and then Descriptors (Interrupt).Static then
+ Raise_Exception (Program_Error'Identity,
+ "Trying to detach a static Interrupt Handler");
+ end if;
+
+ Descriptors (Interrupt) :=
+ (Kind => Unknown, T => null, E => 0, H => null, Static => False);
+
+ if intr_attach (int (Interrupt), null) = FUNC_ERR then
+ raise Program_Error;
+ end if;
+ end Detach_Handler;
+
+ ---------------
+ -- Reference --
+ ---------------
+
+ function Reference (Interrupt : Interrupt_ID) return System.Address is
+ Signal : constant System.Address :=
+ System.Storage_Elements.To_Address
+ (System.Storage_Elements.Integer_Address (Interrupt));
+
+ begin
+ if Is_Reserved (Interrupt) then
+
+ -- Only usable Interrupts can be used for binding it to an Entry
+
+ raise Program_Error;
+ end if;
+
+ return Signal;
+ end Reference;
+
+ --------------------------------
+ -- Register_Interrupt_Handler --
+ --------------------------------
+
+ procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is
+ begin
+ Registered_Handlers :=
+ new Registered_Handler'(H => Handler_Addr, Next => Registered_Handlers);
+ end Register_Interrupt_Handler;
+
+ -------------------
+ -- Is_Registered --
+ -------------------
+
+ -- See if the Handler has been "pragma"ed using Interrupt_Handler.
+ -- Always consider a null handler as registered.
+
+ function Is_Registered (Handler : Parameterless_Handler) return Boolean is
+ Ptr : R_Link := Registered_Handlers;
+
+ type Fat_Ptr is record
+ Object_Addr : System.Address;
+ Handler_Addr : System.Address;
+ end record;
+
+ function To_Fat_Ptr is new Unchecked_Conversion
+ (Parameterless_Handler, Fat_Ptr);
+
+ Fat : Fat_Ptr;
+
+ begin
+ if Handler = null then
+ return True;
+ end if;
+
+ Fat := To_Fat_Ptr (Handler);
+
+ 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;
+
+ -----------------------------
+ -- Bind_Interrupt_To_Entry --
+ -----------------------------
+
+ 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));
+
+ New_Task : Server_Task_Access;
+
+ begin
+ if Is_Reserved (Interrupt) then
+ raise Program_Error;
+ end if;
+
+ if Descriptors (Interrupt).Kind /= Unknown then
+ Raise_Exception (Program_Error'Identity,
+ "A binding for this interrupt is already present");
+ end if;
+
+ if Handlers (Interrupt) = null then
+ New_Task := new Server_Task (Interrupt);
+ Handlers (Interrupt) := To_System (New_Task.all'Identity);
+ end if;
+
+ if intr_attach (int (Interrupt),
+ TISR (Signal_Handler'Access)) = FUNC_ERR
+ then
+ raise Program_Error;
+ end if;
+
+ Descriptors (Interrupt).Kind := Task_Entry;
+ Descriptors (Interrupt).T := T;
+ Descriptors (Interrupt).E := E;
+
+ -- Indicate the attachment of Interrupt Entry in ATCB. This is needed so
+ -- that when an Interrupt Entry task terminates the binding can be
+ -- cleaned up. The call to unbinding must be make by the task before it
+ -- terminates.
+
+ T.Interrupt_Entry := True;
+ end Bind_Interrupt_To_Entry;
+
+ ------------------------------
+ -- Detach_Interrupt_Entries --
+ ------------------------------
+
+ procedure Detach_Interrupt_Entries (T : Task_Id) is
+ begin
+ for J in Interrupt_ID loop
+ if not Is_Reserved (J) then
+ if Descriptors (J).Kind = Task_Entry
+ and then Descriptors (J).T = T
+ then
+ Descriptors (J).Kind := Unknown;
+
+ if intr_attach (int (J), null) = FUNC_ERR then
+ raise Program_Error;
+ end if;
+ end if;
+ end if;
+ end loop;
+
+ -- Indicate in ATCB that no Interrupt Entries are attached
+
+ T.Interrupt_Entry := True;
+ end Detach_Interrupt_Entries;
+
+ ---------------------
+ -- Block_Interrupt --
+ ---------------------
+
+ procedure Block_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ raise Program_Error;
+ end Block_Interrupt;
+
+ -----------------------
+ -- Unblock_Interrupt --
+ -----------------------
+
+ procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ raise Program_Error;
+ end Unblock_Interrupt;
+
+ ----------------
+ -- Is_Blocked --
+ ----------------
+
+ function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ raise Program_Error;
+ return False;
+ end Is_Blocked;
+
+ task body Server_Task is
+ Desc : Handler_Desc renames Descriptors (Interrupt);
+ Self_Id : constant Task_Id := STPO.Self;
+ Temp : Parameterless_Handler;
+
+ begin
+ Utilities.Make_Independent;
+
+ loop
+ while Interrupt_Count (Interrupt) > 0 loop
+ Interrupt_Count (Interrupt) := Interrupt_Count (Interrupt) - 1;
+ begin
+ case Desc.Kind is
+ when Unknown =>
+ null;
+ when Task_Entry =>
+ Rendezvous.Call_Simple (Desc.T, Desc.E, Null_Address);
+ when Protected_Procedure =>
+ Temp := Desc.H;
+ Temp.all;
+ end case;
+ exception
+ when others => null;
+ end;
+ end loop;
+
+ Initialization.Defer_Abort (Self_Id);
+
+ if Single_Lock then
+ STPO.Lock_RTS;
+ end if;
+
+ STPO.Write_Lock (Self_Id);
+ Self_Id.Common.State := Interrupt_Server_Idle_Sleep;
+ STPO.Sleep (Self_Id, Interrupt_Server_Idle_Sleep);
+ Self_Id.Common.State := Runnable;
+ STPO.Unlock (Self_Id);
+
+ if Single_Lock then
+ STPO.Unlock_RTS;
+ end if;
+
+ Initialization.Undefer_Abort (Self_Id);
+
+ -- Undefer abort here to allow a window for this task to be aborted
+ -- at the time of system shutdown.
+
+ end loop;
+ end Server_Task;
+
+end System.Interrupts;