1 ------------------------------------------------------------------------------
3 -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- S Y S T E M . I N T E R R U P T S --
9 -- Copyright (C) 1998-2002 Free Software Fundation --
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. --
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. --
29 -- GNARL was developed by the GNARL team at Florida State University. --
30 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
32 ------------------------------------------------------------------------------
34 -- This is the IRIX & NT version of this package.
36 with Ada.Task_Identification;
40 -- used for Raise_Exception
42 with System.OS_Interface;
43 -- used for intr_attach
45 with System.Storage_Elements;
46 -- used for To_Address
49 with System.Task_Primitives.Operations;
56 with System.Tasking.Utilities;
57 -- used for Make_Independent
59 with System.Tasking.Rendezvous;
60 -- used for Call_Simple
62 with System.Tasking.Initialization;
63 -- used for Defer_Abort
66 with System.Interrupt_Management;
68 with System.Parameters;
69 -- used for Single_Lock
74 with Unchecked_Conversion;
76 package body System.Interrupts is
81 use System.OS_Interface;
84 package STPO renames System.Task_Primitives.Operations;
85 package IMNG renames System.Interrupt_Management;
87 subtype int is Interfaces.C.int;
89 function To_System is new Unchecked_Conversion
90 (Ada.Task_Identification.Task_Id, Task_ID);
92 type Handler_Kind is (Unknown, Task_Entry, Protected_Procedure);
94 type Handler_Desc is record
95 Kind : Handler_Kind := Unknown;
98 H : Parameterless_Handler;
99 Static : Boolean := False;
102 task type Server_Task (Interrupt : Interrupt_ID) is
103 pragma Interrupt_Priority (System.Interrupt_Priority'Last);
106 type Server_Task_Access is access Server_Task;
108 Attached_Interrupts : array (Interrupt_ID) of Boolean;
109 Handlers : array (Interrupt_ID) of Task_ID;
110 Descriptors : array (Interrupt_ID) of Handler_Desc;
111 Interrupt_Count : array (Interrupt_ID) of Integer := (others => 0);
113 pragma Volatile_Components (Interrupt_Count);
115 procedure Attach_Handler
116 (New_Handler : Parameterless_Handler;
117 Interrupt : Interrupt_ID;
119 Restoration : Boolean);
120 -- This internal procedure is needed to finalize protected objects
121 -- that contain interrupt handlers.
123 procedure Signal_Handler (Sig : Interrupt_ID);
124 -- This procedure is used to handle all the signals.
126 -- Type and Head, Tail of the list containing Registered Interrupt
127 -- Handlers. These definitions are used to register the handlers
128 -- specified by the pragma Interrupt_Handler.
131 -- Handler Registration:
134 type Registered_Handler;
135 type R_Link is access all Registered_Handler;
137 type Registered_Handler is record
138 H : System.Address := System.Null_Address;
139 Next : R_Link := null;
142 Registered_Handlers : R_Link := null;
144 function Is_Registered (Handler : Parameterless_Handler) return Boolean;
145 -- See if the Handler has been "pragma"ed using Interrupt_Handler.
146 -- Always consider a null handler as registered.
148 type Handler_Ptr is access procedure (Sig : Interrupt_ID);
150 function TISR is new Unchecked_Conversion (Handler_Ptr, isr_address);
152 procedure Signal_Handler (Sig : Interrupt_ID) is
153 Handler : Task_ID renames Handlers (Sig);
155 if Intr_Attach_Reset and then
156 intr_attach (int (Sig), TISR (Signal_Handler'Access)) = FUNC_ERR
161 if Handler /= null then
162 Interrupt_Count (Sig) := Interrupt_Count (Sig) + 1;
163 STPO.Wakeup (Handler, Interrupt_Server_Idle_Sleep);
171 function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
173 return IMNG.Reserve (IMNG.Interrupt_ID (Interrupt));
176 -----------------------
177 -- Is_Entry_Attached --
178 -----------------------
180 function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
182 if Is_Reserved (Interrupt) then
183 Raise_Exception (Program_Error'Identity, "Interrupt" &
184 Interrupt_ID'Image (Interrupt) & " is reserved");
187 return Descriptors (Interrupt).T /= Null_Task;
188 end Is_Entry_Attached;
190 -------------------------
191 -- Is_Handler_Attached --
192 -------------------------
194 function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
196 if Is_Reserved (Interrupt) then
197 Raise_Exception (Program_Error'Identity, "Interrupt" &
198 Interrupt_ID'Image (Interrupt) & " is reserved");
201 return Descriptors (Interrupt).Kind /= Unknown;
202 end Is_Handler_Attached;
208 function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
218 function Unblocked_By (Interrupt : Interrupt_ID) return Task_ID is
224 ----------------------
225 -- Ignore_Interrupt --
226 ----------------------
228 procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
231 end Ignore_Interrupt;
233 ------------------------
234 -- Unignore_Interrupt --
235 ------------------------
237 procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
240 end Unignore_Interrupt;
242 -------------------------------------
243 -- Has_Interrupt_Or_Attach_Handler --
244 -------------------------------------
246 function Has_Interrupt_Or_Attach_Handler
247 (Object : access Dynamic_Interrupt_Protection)
250 pragma Unreferenced (Object);
254 end Has_Interrupt_Or_Attach_Handler;
260 procedure Finalize (Object : in out Static_Interrupt_Protection) is
262 -- ??? loop to be executed only when we're not doing library level
263 -- finalization, since in this case all interrupt tasks are gone.
265 for N in reverse Object.Previous_Handlers'Range loop
267 (New_Handler => Object.Previous_Handlers (N).Handler,
268 Interrupt => Object.Previous_Handlers (N).Interrupt,
269 Static => Object.Previous_Handlers (N).Static,
270 Restoration => True);
273 Tasking.Protected_Objects.Entries.Finalize
274 (Tasking.Protected_Objects.Entries.Protection_Entries (Object));
277 -------------------------------------
278 -- Has_Interrupt_Or_Attach_Handler --
279 -------------------------------------
281 function Has_Interrupt_Or_Attach_Handler
282 (Object : access Static_Interrupt_Protection)
285 pragma Unreferenced (Object);
289 end Has_Interrupt_Or_Attach_Handler;
291 ----------------------
292 -- Install_Handlers --
293 ----------------------
295 procedure Install_Handlers
296 (Object : access Static_Interrupt_Protection;
297 New_Handlers : New_Handler_Array)
300 for N in New_Handlers'Range loop
302 -- We need a lock around this ???
304 Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt;
305 Object.Previous_Handlers (N).Static := Descriptors
306 (New_Handlers (N).Interrupt).Static;
308 -- We call Exchange_Handler and not directly Interrupt_Manager.
309 -- Exchange_Handler so we get the Is_Reserved check.
312 (Old_Handler => Object.Previous_Handlers (N).Handler,
313 New_Handler => New_Handlers (N).Handler,
314 Interrupt => New_Handlers (N).Interrupt,
317 end Install_Handlers;
319 ---------------------
320 -- Current_Handler --
321 ---------------------
323 function Current_Handler (Interrupt : Interrupt_ID)
324 return Parameterless_Handler is
326 if Is_Reserved (Interrupt) then
330 if Descriptors (Interrupt).Kind = Protected_Procedure then
331 return Descriptors (Interrupt).H;
341 procedure Attach_Handler
342 (New_Handler : Parameterless_Handler;
343 Interrupt : Interrupt_ID;
344 Static : Boolean := False) is
346 Attach_Handler (New_Handler, Interrupt, Static, False);
349 procedure Attach_Handler
350 (New_Handler : Parameterless_Handler;
351 Interrupt : Interrupt_ID;
353 Restoration : Boolean)
355 New_Task : Server_Task_Access;
358 if Is_Reserved (Interrupt) then
362 if not Restoration and then not Static
364 -- Tries to overwrite a static Interrupt Handler with a
367 and then (Descriptors (Interrupt).Static
369 -- The new handler is not specified as an
370 -- Interrupt Handler by a pragma.
372 or else not Is_Registered (New_Handler))
374 Raise_Exception (Program_Error'Identity,
375 "Trying to overwrite a static Interrupt Handler with a " &
379 if Handlers (Interrupt) = null then
380 New_Task := new Server_Task (Interrupt);
381 Handlers (Interrupt) := To_System (New_Task.all'Identity);
384 if intr_attach (int (Interrupt),
385 TISR (Signal_Handler'Access)) = FUNC_ERR
390 if New_Handler = null then
392 -- The null handler means we are detaching the handler.
394 Attached_Interrupts (Interrupt) := False;
395 Descriptors (Interrupt) :=
396 (Kind => Unknown, T => null, E => 0, H => null, Static => False);
399 Descriptors (Interrupt).Kind := Protected_Procedure;
400 Descriptors (Interrupt).H := New_Handler;
401 Descriptors (Interrupt).Static := Static;
402 Attached_Interrupts (Interrupt) := True;
406 ----------------------
407 -- Exchange_Handler --
408 ----------------------
410 procedure Exchange_Handler
411 (Old_Handler : out Parameterless_Handler;
412 New_Handler : Parameterless_Handler;
413 Interrupt : Interrupt_ID;
414 Static : Boolean := False) is
416 if Is_Reserved (Interrupt) then
420 if Descriptors (Interrupt).Kind = Task_Entry then
422 -- In case we have an Interrupt Entry already installed.
423 -- raise a program error. (propagate it to the caller).
425 Raise_Exception (Program_Error'Identity,
426 "An interrupt is already installed");
429 Old_Handler := Current_Handler (Interrupt);
430 Attach_Handler (New_Handler, Interrupt, Static);
431 end Exchange_Handler;
437 procedure Detach_Handler
438 (Interrupt : Interrupt_ID;
439 Static : Boolean := False) is
441 if Is_Reserved (Interrupt) then
445 if Descriptors (Interrupt).Kind = Task_Entry then
446 Raise_Exception (Program_Error'Identity,
447 "Trying to detach an Interrupt Entry");
450 if not Static and then Descriptors (Interrupt).Static then
451 Raise_Exception (Program_Error'Identity,
452 "Trying to detach a static Interrupt Handler");
455 Attached_Interrupts (Interrupt) := False;
456 Descriptors (Interrupt) :=
457 (Kind => Unknown, T => null, E => 0, H => null, Static => False);
459 if intr_attach (int (Interrupt), null) = FUNC_ERR then
468 function Reference (Interrupt : Interrupt_ID) return System.Address is
469 Signal : System.Address :=
470 System.Storage_Elements.To_Address
471 (System.Storage_Elements.Integer_Address (Interrupt));
474 if Is_Reserved (Interrupt) then
475 -- Only usable Interrupts can be used for binding it to an Entry.
482 --------------------------------
483 -- Register_Interrupt_Handler --
484 --------------------------------
486 procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is
488 Registered_Handlers :=
489 new Registered_Handler'(H => Handler_Addr, Next => Registered_Handlers);
490 end Register_Interrupt_Handler;
496 -- See if the Handler has been "pragma"ed using Interrupt_Handler.
497 -- Always consider a null handler as registered.
499 function Is_Registered (Handler : Parameterless_Handler) return Boolean is
500 Ptr : R_Link := Registered_Handlers;
502 type Fat_Ptr is record
503 Object_Addr : System.Address;
504 Handler_Addr : System.Address;
507 function To_Fat_Ptr is new Unchecked_Conversion
508 (Parameterless_Handler, Fat_Ptr);
513 if Handler = null then
517 Fat := To_Fat_Ptr (Handler);
519 while Ptr /= null loop
521 if Ptr.H = Fat.Handler_Addr then
531 -----------------------------
532 -- Bind_Interrupt_To_Entry --
533 -----------------------------
535 procedure Bind_Interrupt_To_Entry
537 E : Task_Entry_Index;
538 Int_Ref : System.Address)
540 Interrupt : constant Interrupt_ID :=
541 Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
543 New_Task : Server_Task_Access;
546 if Is_Reserved (Interrupt) then
550 if Descriptors (Interrupt).Kind /= Unknown then
551 Raise_Exception (Program_Error'Identity,
552 "A binding for this interrupt is already present");
555 if Handlers (Interrupt) = null then
556 New_Task := new Server_Task (Interrupt);
557 Handlers (Interrupt) := To_System (New_Task.all'Identity);
560 if intr_attach (int (Interrupt),
561 TISR (Signal_Handler'Access)) = FUNC_ERR
566 Descriptors (Interrupt).Kind := Task_Entry;
567 Descriptors (Interrupt).T := T;
568 Descriptors (Interrupt).E := E;
570 -- Indicate the attachment of Interrupt Entry in ATCB.
571 -- This is need so that when an Interrupt Entry task terminates
572 -- the binding can be cleaned. The call to unbinding must be
573 -- make by the task before it terminates.
575 T.Interrupt_Entry := True;
577 Attached_Interrupts (Interrupt) := True;
578 end Bind_Interrupt_To_Entry;
580 ------------------------------
581 -- Detach_Interrupt_Entries --
582 ------------------------------
584 procedure Detach_Interrupt_Entries (T : Task_ID) is
586 for I in Interrupt_ID loop
587 if not Is_Reserved (I) then
588 if Descriptors (I).Kind = Task_Entry and then
589 Descriptors (I).T = T then
590 Attached_Interrupts (I) := False;
591 Descriptors (I).Kind := Unknown;
593 if intr_attach (int (I), null) = FUNC_ERR then
600 -- Indicate in ATCB that no Interrupt Entries are attached.
602 T.Interrupt_Entry := True;
603 end Detach_Interrupt_Entries;
605 ---------------------
606 -- Block_Interrupt --
607 ---------------------
609 procedure Block_Interrupt (Interrupt : Interrupt_ID) is
614 -----------------------
615 -- Unblock_Interrupt --
616 -----------------------
618 procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
621 end Unblock_Interrupt;
627 function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
633 task body Server_Task is
634 Desc : Handler_Desc renames Descriptors (Interrupt);
635 Self_Id : Task_ID := STPO.Self;
636 Temp : Parameterless_Handler;
639 Utilities.Make_Independent;
642 while Interrupt_Count (Interrupt) > 0 loop
643 Interrupt_Count (Interrupt) := Interrupt_Count (Interrupt) - 1;
649 Rendezvous.Call_Simple (Desc.T, Desc.E, Null_Address);
650 when Protected_Procedure =>
659 Initialization.Defer_Abort (Self_Id);
665 STPO.Write_Lock (Self_Id);
666 Self_Id.Common.State := Interrupt_Server_Idle_Sleep;
667 STPO.Sleep (Self_Id, Interrupt_Server_Idle_Sleep);
668 Self_Id.Common.State := Runnable;
669 STPO.Unlock (Self_Id);
675 Initialization.Undefer_Abort (Self_Id);
677 -- Undefer abort here to allow a window for this task
678 -- to be aborted at the time of system shutdown.
683 end System.Interrupts;