+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNU ADA 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 --
--- --
--- $Revision: 1.1.16.1 $
--- --
--- Copyright (C) 1998-1999 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, 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. --
--- 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.OS_Interface;
--- used for intr_attach
-
-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 Interfaces.C;
--- used for int
-
-with Unchecked_Conversion;
-
-package body System.Interrupts is
-
- 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;
-
- Attached_Interrupts : array (Interrupt_ID) of Boolean;
- 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);
-
- 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
- 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
- begin
- return True;
- end Has_Interrupt_Or_Attach_Handler;
-
- ----------------------
- -- Install_Handlers --
- ----------------------
-
- procedure Install_Handlers
- (Object : access Static_Interrupt_Protection;
- New_Handlers : in 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 a
- -- dynamic Handler
-
- and then (Descriptors (Interrupt).Static
-
- -- The new handler is 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.
-
- Attached_Interrupts (Interrupt) := False;
- 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;
- Attached_Interrupts (Interrupt) := True;
- 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;
-
- Attached_Interrupts (Interrupt) := False;
- 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 : 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 need so that when an Interrupt Entry task terminates
- -- the binding can be cleaned. The call to unbinding must be
- -- make by the task before it terminates.
-
- T.Interrupt_Entry := True;
-
- Attached_Interrupts (Interrupt) := True;
- end Bind_Interrupt_To_Entry;
-
- ------------------------------
- -- Detach_Interrupt_Entries --
- ------------------------------
-
- procedure Detach_Interrupt_Entries (T : Task_ID) is
- begin
- for I in Interrupt_ID loop
- if not Is_Reserved (I) then
- if Descriptors (I).Kind = Task_Entry and then
- Descriptors (I).T = T then
- Attached_Interrupts (I) := False;
- Descriptors (I).Kind := Unknown;
-
- if intr_attach (int (I), 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 : 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);
- 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);
- 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;
projects / msp430-gcc.git / blobdiff