Update ChangeLog and version files for release
[official-gcc.git] / gcc / ada / s-interr.adb
blob3c988af5a02ee72e0aac7ce7b66525f69a83eafa
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
4 -- --
5 -- S Y S T E M . I N T E R R U P T S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
10 -- --
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 3, or (at your option) any later ver- --
14 -- sion. GNAT 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. --
17 -- --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
21 -- --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 -- --
27 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
29 -- --
30 ------------------------------------------------------------------------------
32 -- Invariants:
34 -- All user-handleable interrupts are masked at all times in all tasks/threads
35 -- except possibly for the Interrupt_Manager task.
37 -- When a user task wants to achieve masking/unmasking an interrupt, it must
38 -- call Block_Interrupt/Unblock_Interrupt, which will have the effect of
39 -- unmasking/masking the interrupt in the Interrupt_Manager task.
41 -- Note : Direct calls to sigaction, sigprocmask, pthread_sigsetmask or any
42 -- other low-level interface that changes the interrupt action or
43 -- interrupt mask needs a careful thought.
45 -- One may achieve the effect of system calls first masking RTS blocked
46 -- (by calling Block_Interrupt) for the interrupt under consideration.
47 -- This will make all the tasks in RTS blocked for the Interrupt.
49 -- Once we associate a Server_Task with an interrupt, the task never goes
50 -- away, and we never remove the association.
52 -- There is no more than one interrupt per Server_Task and no more than one
53 -- Server_Task per interrupt.
55 with Ada.Exceptions;
56 with Ada.Task_Identification;
58 with System.Task_Primitives;
59 with System.Interrupt_Management;
61 with System.Interrupt_Management.Operations;
62 pragma Elaborate_All (System.Interrupt_Management.Operations);
64 with System.IO;
66 with System.Task_Primitives.Operations;
67 with System.Task_Primitives.Interrupt_Operations;
68 with System.Storage_Elements;
69 with System.Tasking.Utilities;
71 with System.Tasking.Rendezvous;
72 pragma Elaborate_All (System.Tasking.Rendezvous);
74 with System.Tasking.Initialization;
75 with System.Parameters;
77 with Ada.Unchecked_Conversion;
79 package body System.Interrupts is
81 use Parameters;
82 use Tasking;
84 package POP renames System.Task_Primitives.Operations;
85 package PIO renames System.Task_Primitives.Interrupt_Operations;
86 package IMNG renames System.Interrupt_Management;
87 package IMOP renames System.Interrupt_Management.Operations;
89 function To_System is new Ada.Unchecked_Conversion
90 (Ada.Task_Identification.Task_Id, Task_Id);
92 -----------------
93 -- Local Tasks --
94 -----------------
96 -- WARNING: System.Tasking.Stages performs calls to this task with
97 -- low-level constructs. Do not change this spec without synchronizing it.
99 task Interrupt_Manager is
100 entry Detach_Interrupt_Entries (T : Task_Id);
102 entry Initialize (Mask : IMNG.Interrupt_Mask);
104 entry Attach_Handler
105 (New_Handler : Parameterless_Handler;
106 Interrupt : Interrupt_ID;
107 Static : Boolean;
108 Restoration : Boolean := False);
110 entry Exchange_Handler
111 (Old_Handler : out Parameterless_Handler;
112 New_Handler : Parameterless_Handler;
113 Interrupt : Interrupt_ID;
114 Static : Boolean);
116 entry Detach_Handler
117 (Interrupt : Interrupt_ID;
118 Static : Boolean);
120 entry Bind_Interrupt_To_Entry
121 (T : Task_Id;
122 E : Task_Entry_Index;
123 Interrupt : Interrupt_ID);
125 entry Block_Interrupt (Interrupt : Interrupt_ID);
127 entry Unblock_Interrupt (Interrupt : Interrupt_ID);
129 entry Ignore_Interrupt (Interrupt : Interrupt_ID);
131 entry Unignore_Interrupt (Interrupt : Interrupt_ID);
133 pragma Interrupt_Priority (System.Interrupt_Priority'Last);
134 end Interrupt_Manager;
136 task type Server_Task (Interrupt : Interrupt_ID) is
137 pragma Priority (System.Interrupt_Priority'Last);
138 -- Note: the above pragma Priority is strictly speaking improper since
139 -- it is outside the range of allowed priorities, but the compiler
140 -- treats system units specially and does not apply this range checking
141 -- rule to system units.
143 end Server_Task;
145 type Server_Task_Access is access Server_Task;
147 -------------------------------
148 -- Local Types and Variables --
149 -------------------------------
151 type Entry_Assoc is record
152 T : Task_Id;
153 E : Task_Entry_Index;
154 end record;
156 type Handler_Assoc is record
157 H : Parameterless_Handler;
158 Static : Boolean; -- Indicates static binding;
159 end record;
161 User_Handler : array (Interrupt_ID'Range) of Handler_Assoc :=
162 (others => (null, Static => False));
163 pragma Volatile_Components (User_Handler);
164 -- Holds the protected procedure handler (if any) and its Static
165 -- information for each interrupt. A handler is a Static one if it is
166 -- specified through the pragma Attach_Handler. Attach_Handler. Otherwise,
167 -- not static)
169 User_Entry : array (Interrupt_ID'Range) of Entry_Assoc :=
170 (others => (T => Null_Task, E => Null_Task_Entry));
171 pragma Volatile_Components (User_Entry);
172 -- Holds the task and entry index (if any) for each interrupt
174 Blocked : array (Interrupt_ID'Range) of Boolean := (others => False);
175 pragma Atomic_Components (Blocked);
176 -- True iff the corresponding interrupt is blocked in the process level
178 Ignored : array (Interrupt_ID'Range) of Boolean := (others => False);
179 pragma Atomic_Components (Ignored);
180 -- True iff the corresponding interrupt is blocked in the process level
182 Last_Unblocker :
183 array (Interrupt_ID'Range) of Task_Id := (others => Null_Task);
184 pragma Atomic_Components (Last_Unblocker);
185 -- Holds the ID of the last Task which Unblocked this Interrupt. It
186 -- contains Null_Task if no tasks have ever requested the Unblocking
187 -- operation or the Interrupt is currently Blocked.
189 Server_ID : array (Interrupt_ID'Range) of Task_Id :=
190 (others => Null_Task);
191 pragma Atomic_Components (Server_ID);
192 -- Holds the Task_Id of the Server_Task for each interrupt. Task_Id is
193 -- needed to accomplish locking per Interrupt base. Also is needed to
194 -- decide whether to create a new Server_Task.
196 -- Type and Head, Tail of the list containing Registered Interrupt
197 -- Handlers. These definitions are used to register the handlers
198 -- specified by the pragma Interrupt_Handler.
200 type Registered_Handler;
201 type R_Link is access all Registered_Handler;
203 type Registered_Handler is record
204 H : System.Address := System.Null_Address;
205 Next : R_Link := null;
206 end record;
208 Registered_Handler_Head : R_Link := null;
209 Registered_Handler_Tail : R_Link := null;
211 Access_Hold : Server_Task_Access;
212 -- Variable used to allocate Server_Task using "new"
214 -----------------------
215 -- Local Subprograms --
216 -----------------------
218 function Is_Registered (Handler : Parameterless_Handler) return Boolean;
219 -- See if the Handler has been "pragma"ed using Interrupt_Handler. Always
220 -- consider a null handler as registered.
222 --------------------
223 -- Attach_Handler --
224 --------------------
226 -- Calling this procedure with New_Handler = null and Static = True means
227 -- we want to detach the current handler regardless of the previous
228 -- handler's binding status (i.e. do not care if it is a dynamic or static
229 -- handler).
231 -- This option is needed so that during the finalization of a PO, we can
232 -- detach handlers attached through pragma Attach_Handler.
234 procedure Attach_Handler
235 (New_Handler : Parameterless_Handler;
236 Interrupt : Interrupt_ID;
237 Static : Boolean := False)
239 begin
240 if Is_Reserved (Interrupt) then
241 raise Program_Error with
242 "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
243 end if;
245 Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static);
247 end Attach_Handler;
249 -----------------------------
250 -- Bind_Interrupt_To_Entry --
251 -----------------------------
253 -- This procedure raises a Program_Error if it tries to bind an interrupt
254 -- to which an Entry or a Procedure is already bound.
256 procedure Bind_Interrupt_To_Entry
257 (T : Task_Id;
258 E : Task_Entry_Index;
259 Int_Ref : System.Address)
261 Interrupt : constant Interrupt_ID :=
262 Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
264 begin
265 if Is_Reserved (Interrupt) then
266 raise Program_Error with
267 "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
268 end if;
270 Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt);
271 end Bind_Interrupt_To_Entry;
273 ---------------------
274 -- Block_Interrupt --
275 ---------------------
277 procedure Block_Interrupt (Interrupt : Interrupt_ID) is
278 begin
279 if Is_Reserved (Interrupt) then
280 raise Program_Error with
281 "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
282 end if;
284 Interrupt_Manager.Block_Interrupt (Interrupt);
285 end Block_Interrupt;
287 ---------------------
288 -- Current_Handler --
289 ---------------------
291 function Current_Handler
292 (Interrupt : Interrupt_ID) return Parameterless_Handler
294 begin
295 if Is_Reserved (Interrupt) then
296 raise Program_Error with
297 "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
298 end if;
300 -- ??? Since Parameterless_Handler is not Atomic, the current
301 -- implementation is wrong. We need a new service in Interrupt_Manager
302 -- to ensure atomicity.
304 return User_Handler (Interrupt).H;
305 end Current_Handler;
307 --------------------
308 -- Detach_Handler --
309 --------------------
311 -- Calling this procedure with Static = True means we want to Detach the
312 -- current handler regardless of the previous handler's binding status
313 -- (i.e. do not care if it is a dynamic or static handler).
315 -- This option is needed so that during the finalization of a PO, we can
316 -- detach handlers attached through pragma Attach_Handler.
318 procedure Detach_Handler
319 (Interrupt : Interrupt_ID;
320 Static : Boolean := False)
322 begin
323 if Is_Reserved (Interrupt) then
324 raise Program_Error with
325 "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
326 end if;
328 Interrupt_Manager.Detach_Handler (Interrupt, Static);
329 end Detach_Handler;
331 ------------------------------
332 -- Detach_Interrupt_Entries --
333 ------------------------------
335 procedure Detach_Interrupt_Entries (T : Task_Id) is
336 begin
337 Interrupt_Manager.Detach_Interrupt_Entries (T);
338 end Detach_Interrupt_Entries;
340 ----------------------
341 -- Exchange_Handler --
342 ----------------------
344 -- Calling this procedure with New_Handler = null and Static = True means
345 -- we want to detach the current handler regardless of the previous
346 -- handler's binding status (i.e. do not care if it is a dynamic or static
347 -- handler).
349 -- This option is needed so that during the finalization of a PO, we can
350 -- detach handlers attached through pragma Attach_Handler.
352 procedure Exchange_Handler
353 (Old_Handler : out Parameterless_Handler;
354 New_Handler : Parameterless_Handler;
355 Interrupt : Interrupt_ID;
356 Static : Boolean := False)
358 begin
359 if Is_Reserved (Interrupt) then
360 raise Program_Error with
361 "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
362 end if;
364 Interrupt_Manager.Exchange_Handler
365 (Old_Handler, New_Handler, Interrupt, Static);
366 end Exchange_Handler;
368 --------------
369 -- Finalize --
370 --------------
372 procedure Finalize (Object : in out Static_Interrupt_Protection) is
373 function State
374 (Int : System.Interrupt_Management.Interrupt_ID) return Character;
375 pragma Import (C, State, "__gnat_get_interrupt_state");
376 -- Get interrupt state for interrupt number Int. Defined in init.c
378 Default : constant Character := 's';
379 -- 's' Interrupt_State pragma set state to System (use "default"
380 -- system handler)
382 begin
383 -- ??? loop to be executed only when we're not doing library level
384 -- finalization, since in this case all interrupt tasks are gone.
386 -- If the Abort_Task signal is set to system, it means that we cannot
387 -- reset interrupt handlers since this would require sending the abort
388 -- signal to the Server_Task
390 if not Interrupt_Manager'Terminated
391 and then
392 State (System.Interrupt_Management.Abort_Task_Interrupt) /= Default
393 then
394 for N in reverse Object.Previous_Handlers'Range loop
395 Interrupt_Manager.Attach_Handler
396 (New_Handler => Object.Previous_Handlers (N).Handler,
397 Interrupt => Object.Previous_Handlers (N).Interrupt,
398 Static => Object.Previous_Handlers (N).Static,
399 Restoration => True);
400 end loop;
401 end if;
403 Tasking.Protected_Objects.Entries.Finalize
404 (Tasking.Protected_Objects.Entries.Protection_Entries (Object));
405 end Finalize;
407 -------------------------------------
408 -- Has_Interrupt_Or_Attach_Handler --
409 -------------------------------------
411 -- Need comments as to why these always return True ???
413 function Has_Interrupt_Or_Attach_Handler
414 (Object : access Dynamic_Interrupt_Protection) return Boolean
416 pragma Unreferenced (Object);
417 begin
418 return True;
419 end Has_Interrupt_Or_Attach_Handler;
421 function Has_Interrupt_Or_Attach_Handler
422 (Object : access Static_Interrupt_Protection) return Boolean
424 pragma Unreferenced (Object);
425 begin
426 return True;
427 end Has_Interrupt_Or_Attach_Handler;
429 ----------------------
430 -- Ignore_Interrupt --
431 ----------------------
433 procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
434 begin
435 if Is_Reserved (Interrupt) then
436 raise Program_Error with
437 "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
438 end if;
440 Interrupt_Manager.Ignore_Interrupt (Interrupt);
441 end Ignore_Interrupt;
443 ----------------------
444 -- Install_Handlers --
445 ----------------------
447 procedure Install_Handlers
448 (Object : access Static_Interrupt_Protection;
449 New_Handlers : New_Handler_Array)
451 begin
452 for N in New_Handlers'Range loop
454 -- We need a lock around this ???
456 Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt;
457 Object.Previous_Handlers (N).Static := User_Handler
458 (New_Handlers (N).Interrupt).Static;
460 -- We call Exchange_Handler and not directly Interrupt_Manager.
461 -- Exchange_Handler so we get the Is_Reserved check.
463 Exchange_Handler
464 (Old_Handler => Object.Previous_Handlers (N).Handler,
465 New_Handler => New_Handlers (N).Handler,
466 Interrupt => New_Handlers (N).Interrupt,
467 Static => True);
468 end loop;
469 end Install_Handlers;
471 ---------------------------------
472 -- Install_Restricted_Handlers --
473 ---------------------------------
475 procedure Install_Restricted_Handlers
476 (Prio : Any_Priority;
477 Handlers : New_Handler_Array)
479 pragma Unreferenced (Prio);
480 begin
481 for N in Handlers'Range loop
482 Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True);
483 end loop;
484 end Install_Restricted_Handlers;
486 ----------------
487 -- Is_Blocked --
488 ----------------
490 function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
491 begin
492 if Is_Reserved (Interrupt) then
493 raise Program_Error with
494 "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
495 end if;
497 return Blocked (Interrupt);
498 end Is_Blocked;
500 -----------------------
501 -- Is_Entry_Attached --
502 -----------------------
504 function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
505 begin
506 if Is_Reserved (Interrupt) then
507 raise Program_Error with
508 "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
509 end if;
511 return User_Entry (Interrupt).T /= Null_Task;
512 end Is_Entry_Attached;
514 -------------------------
515 -- Is_Handler_Attached --
516 -------------------------
518 function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
519 begin
520 if Is_Reserved (Interrupt) then
521 raise Program_Error with
522 "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
523 end if;
525 return User_Handler (Interrupt).H /= null;
526 end Is_Handler_Attached;
528 ----------------
529 -- Is_Ignored --
530 ----------------
532 function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
533 begin
534 if Is_Reserved (Interrupt) then
535 raise Program_Error with
536 "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
537 end if;
539 return Ignored (Interrupt);
540 end Is_Ignored;
542 -------------------
543 -- Is_Registered --
544 -------------------
546 function Is_Registered (Handler : Parameterless_Handler) return Boolean is
548 type Fat_Ptr is record
549 Object_Addr : System.Address;
550 Handler_Addr : System.Address;
551 end record;
553 function To_Fat_Ptr is new Ada.Unchecked_Conversion
554 (Parameterless_Handler, Fat_Ptr);
556 Ptr : R_Link;
557 Fat : Fat_Ptr;
559 begin
560 if Handler = null then
561 return True;
562 end if;
564 Fat := To_Fat_Ptr (Handler);
566 Ptr := Registered_Handler_Head;
567 while Ptr /= null loop
568 if Ptr.H = Fat.Handler_Addr then
569 return True;
570 end if;
572 Ptr := Ptr.Next;
573 end loop;
575 return False;
576 end Is_Registered;
578 -----------------
579 -- Is_Reserved --
580 -----------------
582 function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
583 begin
584 return IMNG.Reserve (IMNG.Interrupt_ID (Interrupt));
585 end Is_Reserved;
587 ---------------
588 -- Reference --
589 ---------------
591 function Reference (Interrupt : Interrupt_ID) return System.Address is
592 begin
593 if Is_Reserved (Interrupt) then
594 raise Program_Error with
595 "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
596 end if;
598 return Storage_Elements.To_Address
599 (Storage_Elements.Integer_Address (Interrupt));
600 end Reference;
602 ---------------------------------
603 -- Register_Interrupt_Handler --
604 ---------------------------------
606 procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is
607 New_Node_Ptr : R_Link;
609 begin
610 -- This routine registers the Handler as usable for Dynamic Interrupt
611 -- Handler. Routines attaching and detaching Handler dynamically should
612 -- first consult if the Handler is registered. A Program Error should
613 -- be raised if it is not registered.
615 -- The pragma Interrupt_Handler can only appear in the library level PO
616 -- definition and instantiation. Therefore, we do not need to implement
617 -- Unregistering operation. Neither we need to protect the queue
618 -- structure using a Lock.
620 pragma Assert (Handler_Addr /= System.Null_Address);
622 New_Node_Ptr := new Registered_Handler;
623 New_Node_Ptr.H := Handler_Addr;
625 if Registered_Handler_Head = null then
626 Registered_Handler_Head := New_Node_Ptr;
627 Registered_Handler_Tail := New_Node_Ptr;
629 else
630 Registered_Handler_Tail.Next := New_Node_Ptr;
631 Registered_Handler_Tail := New_Node_Ptr;
632 end if;
633 end Register_Interrupt_Handler;
635 -----------------------
636 -- Unblock_Interrupt --
637 -----------------------
639 procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
640 begin
641 if Is_Reserved (Interrupt) then
642 raise Program_Error with
643 "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
644 end if;
646 Interrupt_Manager.Unblock_Interrupt (Interrupt);
647 end Unblock_Interrupt;
649 ------------------
650 -- Unblocked_By --
651 ------------------
653 function Unblocked_By
654 (Interrupt : Interrupt_ID) return System.Tasking.Task_Id
656 begin
657 if Is_Reserved (Interrupt) then
658 raise Program_Error with
659 "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
660 end if;
662 return Last_Unblocker (Interrupt);
663 end Unblocked_By;
665 ------------------------
666 -- Unignore_Interrupt --
667 ------------------------
669 procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
670 begin
671 if Is_Reserved (Interrupt) then
672 raise Program_Error with
673 "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
674 end if;
676 Interrupt_Manager.Unignore_Interrupt (Interrupt);
677 end Unignore_Interrupt;
679 -----------------------
680 -- Interrupt_Manager --
681 -----------------------
683 task body Interrupt_Manager is
684 -- By making this task independent of master, when the process
685 -- goes away, the Interrupt_Manager will terminate gracefully.
687 Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent;
689 ---------------------
690 -- Local Variables --
691 ---------------------
693 Intwait_Mask : aliased IMNG.Interrupt_Mask;
694 Ret_Interrupt : Interrupt_ID;
695 Old_Mask : aliased IMNG.Interrupt_Mask;
696 Old_Handler : Parameterless_Handler;
698 --------------------
699 -- Local Routines --
700 --------------------
702 procedure Bind_Handler (Interrupt : Interrupt_ID);
703 -- This procedure does not do anything if the Interrupt is blocked.
704 -- Otherwise, we have to interrupt Server_Task for status change through
705 -- Wakeup interrupt.
707 procedure Unbind_Handler (Interrupt : Interrupt_ID);
708 -- This procedure does not do anything if the Interrupt is blocked.
709 -- Otherwise, we have to interrupt Server_Task for status change
710 -- through abort interrupt.
712 procedure Unprotected_Exchange_Handler
713 (Old_Handler : out Parameterless_Handler;
714 New_Handler : Parameterless_Handler;
715 Interrupt : Interrupt_ID;
716 Static : Boolean;
717 Restoration : Boolean := False);
719 procedure Unprotected_Detach_Handler
720 (Interrupt : Interrupt_ID;
721 Static : Boolean);
723 ------------------
724 -- Bind_Handler --
725 ------------------
727 procedure Bind_Handler (Interrupt : Interrupt_ID) is
728 begin
729 if not Blocked (Interrupt) then
731 -- Mask this task for the given Interrupt so that all tasks
732 -- are masked for the Interrupt and the actual delivery of the
733 -- Interrupt will be caught using "sigwait" by the
734 -- corresponding Server_Task.
736 IMOP.Thread_Block_Interrupt (IMNG.Interrupt_ID (Interrupt));
738 -- We have installed a Handler or an Entry before we called
739 -- this procedure. If the Handler Task is waiting to be awakened,
740 -- do it here. Otherwise, the interrupt will be discarded.
742 POP.Wakeup (Server_ID (Interrupt), Interrupt_Server_Idle_Sleep);
743 end if;
744 end Bind_Handler;
746 --------------------
747 -- Unbind_Handler --
748 --------------------
750 procedure Unbind_Handler (Interrupt : Interrupt_ID) is
751 Server : System.Tasking.Task_Id;
753 begin
754 if not Blocked (Interrupt) then
756 -- Currently, there is a Handler or an Entry attached and
757 -- corresponding Server_Task is waiting on "sigwait." We have to
758 -- wake up the Server_Task and make it wait on condition variable
759 -- by sending an Abort_Task_Interrupt
761 Server := Server_ID (Interrupt);
763 case Server.Common.State is
764 when Interrupt_Server_Idle_Sleep |
765 Interrupt_Server_Blocked_Interrupt_Sleep
767 POP.Wakeup (Server, Server.Common.State);
769 when Interrupt_Server_Blocked_On_Event_Flag =>
770 POP.Abort_Task (Server);
772 -- Make sure corresponding Server_Task is out of its
773 -- own sigwait state.
775 Ret_Interrupt :=
776 Interrupt_ID (IMOP.Interrupt_Wait (Intwait_Mask'Access));
777 pragma Assert
778 (Ret_Interrupt = Interrupt_ID (IMNG.Abort_Task_Interrupt));
780 when Runnable =>
781 null;
783 when others =>
784 pragma Assert (False);
785 null;
786 end case;
788 IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt));
790 -- Unmake the Interrupt for this task in order to allow default
791 -- action again.
793 IMOP.Thread_Unblock_Interrupt (IMNG.Interrupt_ID (Interrupt));
795 else
796 IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt));
797 end if;
798 end Unbind_Handler;
800 --------------------------------
801 -- Unprotected_Detach_Handler --
802 --------------------------------
804 procedure Unprotected_Detach_Handler
805 (Interrupt : Interrupt_ID;
806 Static : Boolean)
808 Old_Handler : Parameterless_Handler;
810 begin
811 if User_Entry (Interrupt).T /= Null_Task then
813 -- In case we have an Interrupt Entry installed, raise a program
814 -- error, (propagate it to the caller).
816 raise Program_Error with
817 "an interrupt entry is already installed";
818 end if;
820 -- Note : Static = True will pass the following check. That is the
821 -- case when we want to detach a handler regardless of the static
822 -- status of the current_Handler.
824 if not Static and then User_Handler (Interrupt).Static then
826 -- Tries to detach a static Interrupt Handler.
827 -- raise a program error.
829 raise Program_Error with
830 "trying to detach a static interrupt handler";
831 end if;
833 -- The interrupt should no longer be ignored if
834 -- it was ever ignored.
836 Ignored (Interrupt) := False;
838 Old_Handler := User_Handler (Interrupt).H;
840 -- The new handler
842 User_Handler (Interrupt).H := null;
843 User_Handler (Interrupt).Static := False;
845 if Old_Handler /= null then
846 Unbind_Handler (Interrupt);
847 end if;
848 end Unprotected_Detach_Handler;
850 ----------------------------------
851 -- Unprotected_Exchange_Handler --
852 ----------------------------------
854 procedure Unprotected_Exchange_Handler
855 (Old_Handler : out Parameterless_Handler;
856 New_Handler : Parameterless_Handler;
857 Interrupt : Interrupt_ID;
858 Static : Boolean;
859 Restoration : Boolean := False)
861 begin
862 if User_Entry (Interrupt).T /= Null_Task then
864 -- In case we have an Interrupt Entry already installed, raise a
865 -- program error, (propagate it to the caller).
867 raise Program_Error with
868 "an interrupt is already installed";
869 end if;
871 -- Note : A null handler with Static = True will pass the following
872 -- check. That is the case when we want to Detach a handler
873 -- regardless of the Static status of the current_Handler.
875 -- We don't check anything if Restoration is True, since we may be
876 -- detaching a static handler to restore a dynamic one.
878 if not Restoration and then not Static
880 -- Tries to overwrite a static Interrupt Handler with a dynamic
881 -- Handler
883 and then (User_Handler (Interrupt).Static
885 -- The new handler is not specified as an
886 -- Interrupt Handler by a pragma.
888 or else not Is_Registered (New_Handler))
889 then
890 raise Program_Error with
891 "trying to overwrite a static Interrupt Handler with a " &
892 "dynamic handler";
893 end if;
895 -- The interrupt should no longer be ignored if
896 -- it was ever ignored.
898 Ignored (Interrupt) := False;
900 -- Save the old handler
902 Old_Handler := User_Handler (Interrupt).H;
904 -- The new handler
906 User_Handler (Interrupt).H := New_Handler;
908 if New_Handler = null then
910 -- The null handler means we are detaching the handler
912 User_Handler (Interrupt).Static := False;
914 else
915 User_Handler (Interrupt).Static := Static;
916 end if;
918 -- Invoke a corresponding Server_Task if not yet created.
919 -- Place Task_Id info in Server_ID array.
921 if Server_ID (Interrupt) = Null_Task then
923 -- When a new Server_Task is created, it should have its
924 -- signal mask set to the All_Tasks_Mask.
926 IMOP.Set_Interrupt_Mask
927 (IMOP.All_Tasks_Mask'Access, Old_Mask'Access);
928 Access_Hold := new Server_Task (Interrupt);
929 IMOP.Set_Interrupt_Mask (Old_Mask'Access);
931 Server_ID (Interrupt) := To_System (Access_Hold.all'Identity);
932 end if;
934 if New_Handler = null then
935 if Old_Handler /= null then
936 Unbind_Handler (Interrupt);
937 end if;
939 return;
940 end if;
942 if Old_Handler = null then
943 Bind_Handler (Interrupt);
944 end if;
945 end Unprotected_Exchange_Handler;
947 -- Start of processing for Interrupt_Manager
949 begin
950 -- Environment task gets its own interrupt mask, saves it, and then
951 -- masks all interrupts except the Keep_Unmasked set.
953 -- During rendezvous, the Interrupt_Manager receives the old interrupt
954 -- mask of the environment task, and sets its own interrupt mask to that
955 -- value.
957 -- The environment task will call the entry of Interrupt_Manager some
958 -- during elaboration of the body of this package.
960 accept Initialize (Mask : IMNG.Interrupt_Mask) do
961 declare
962 The_Mask : aliased IMNG.Interrupt_Mask;
963 begin
964 IMOP.Copy_Interrupt_Mask (The_Mask, Mask);
965 IMOP.Set_Interrupt_Mask (The_Mask'Access);
966 end;
967 end Initialize;
969 -- Note: All tasks in RTS will have all the Reserve Interrupts being
970 -- masked (except the Interrupt_Manager) and Keep_Unmasked unmasked
971 -- when created.
973 -- Abort_Task_Interrupt is one of the Interrupt unmasked in all tasks.
974 -- We mask the Interrupt in this particular task so that "sigwait" is
975 -- possible to catch an explicitly sent Abort_Task_Interrupt from the
976 -- Server_Tasks.
978 -- This sigwaiting is needed so that we make sure a Server_Task is out
979 -- of its own sigwait state. This extra synchronization is necessary to
980 -- prevent following scenarios.
982 -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to the
983 -- Server_Task then changes its own interrupt mask (OS level).
984 -- If an interrupt (corresponding to the Server_Task) arrives
985 -- in the mean time we have the Interrupt_Manager unmasked and
986 -- the Server_Task waiting on sigwait.
988 -- 2) For unbinding handler, we install a default action in the
989 -- Interrupt_Manager. POSIX.1c states that the result of using
990 -- "sigwait" and "sigaction" simultaneously on the same interrupt
991 -- is undefined. Therefore, we need to be informed from the
992 -- Server_Task of the fact that the Server_Task is out of its
993 -- sigwait stage.
995 IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access);
996 IMOP.Add_To_Interrupt_Mask
997 (Intwait_Mask'Access, IMNG.Abort_Task_Interrupt);
998 IMOP.Thread_Block_Interrupt
999 (IMNG.Abort_Task_Interrupt);
1001 loop
1002 -- A block is needed to absorb Program_Error exception
1004 begin
1005 select
1006 accept Attach_Handler
1007 (New_Handler : Parameterless_Handler;
1008 Interrupt : Interrupt_ID;
1009 Static : Boolean;
1010 Restoration : Boolean := False)
1012 Unprotected_Exchange_Handler
1013 (Old_Handler, New_Handler, Interrupt, Static, Restoration);
1014 end Attach_Handler;
1017 accept Exchange_Handler
1018 (Old_Handler : out Parameterless_Handler;
1019 New_Handler : Parameterless_Handler;
1020 Interrupt : Interrupt_ID;
1021 Static : Boolean)
1023 Unprotected_Exchange_Handler
1024 (Old_Handler, New_Handler, Interrupt, Static);
1025 end Exchange_Handler;
1028 accept Detach_Handler
1029 (Interrupt : Interrupt_ID;
1030 Static : Boolean)
1032 Unprotected_Detach_Handler (Interrupt, Static);
1033 end Detach_Handler;
1036 accept Bind_Interrupt_To_Entry
1037 (T : Task_Id;
1038 E : Task_Entry_Index;
1039 Interrupt : Interrupt_ID)
1041 -- If there is a binding already (either a procedure or an
1042 -- entry), raise Program_Error (propagate it to the caller).
1044 if User_Handler (Interrupt).H /= null
1045 or else User_Entry (Interrupt).T /= Null_Task
1046 then
1047 raise Program_Error with
1048 "a binding for this interrupt is already present";
1049 end if;
1051 -- The interrupt should no longer be ignored if
1052 -- it was ever ignored.
1054 Ignored (Interrupt) := False;
1055 User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E);
1057 -- Indicate the attachment of Interrupt Entry in ATCB.
1058 -- This is need so that when an Interrupt Entry task
1059 -- terminates the binding can be cleaned. The call to
1060 -- unbinding must be made by the task before it terminates.
1062 T.Interrupt_Entry := True;
1064 -- Invoke a corresponding Server_Task if not yet created.
1065 -- Place Task_Id info in Server_ID array.
1067 if Server_ID (Interrupt) = Null_Task then
1069 -- When a new Server_Task is created, it should have its
1070 -- signal mask set to the All_Tasks_Mask.
1072 IMOP.Set_Interrupt_Mask
1073 (IMOP.All_Tasks_Mask'Access, Old_Mask'Access);
1074 Access_Hold := new Server_Task (Interrupt);
1075 IMOP.Set_Interrupt_Mask (Old_Mask'Access);
1076 Server_ID (Interrupt) :=
1077 To_System (Access_Hold.all'Identity);
1078 end if;
1080 Bind_Handler (Interrupt);
1081 end Bind_Interrupt_To_Entry;
1084 accept Detach_Interrupt_Entries (T : Task_Id) do
1085 for J in Interrupt_ID'Range loop
1086 if not Is_Reserved (J) then
1087 if User_Entry (J).T = T then
1089 -- The interrupt should no longer be ignored if
1090 -- it was ever ignored.
1092 Ignored (J) := False;
1093 User_Entry (J) := Entry_Assoc'
1094 (T => Null_Task, E => Null_Task_Entry);
1095 Unbind_Handler (J);
1096 end if;
1097 end if;
1098 end loop;
1100 -- Indicate in ATCB that no Interrupt Entries are attached
1102 T.Interrupt_Entry := False;
1103 end Detach_Interrupt_Entries;
1106 accept Block_Interrupt (Interrupt : Interrupt_ID) do
1107 if Blocked (Interrupt) then
1108 return;
1109 end if;
1111 Blocked (Interrupt) := True;
1112 Last_Unblocker (Interrupt) := Null_Task;
1114 -- Mask this task for the given Interrupt so that all tasks
1115 -- are masked for the Interrupt.
1117 IMOP.Thread_Block_Interrupt (IMNG.Interrupt_ID (Interrupt));
1119 if User_Handler (Interrupt).H /= null
1120 or else User_Entry (Interrupt).T /= Null_Task
1121 then
1122 -- This is the case where the Server_Task is
1123 -- waiting on "sigwait." Wake it up by sending an
1124 -- Abort_Task_Interrupt so that the Server_Task waits
1125 -- on Cond.
1127 POP.Abort_Task (Server_ID (Interrupt));
1129 -- Make sure corresponding Server_Task is out of its own
1130 -- sigwait state.
1132 Ret_Interrupt := Interrupt_ID
1133 (IMOP.Interrupt_Wait (Intwait_Mask'Access));
1134 pragma Assert
1135 (Ret_Interrupt =
1136 Interrupt_ID (IMNG.Abort_Task_Interrupt));
1137 end if;
1138 end Block_Interrupt;
1141 accept Unblock_Interrupt (Interrupt : Interrupt_ID) do
1142 if not Blocked (Interrupt) then
1143 return;
1144 end if;
1146 Blocked (Interrupt) := False;
1147 Last_Unblocker (Interrupt) :=
1148 To_System (Unblock_Interrupt'Caller);
1150 if User_Handler (Interrupt).H = null
1151 and then User_Entry (Interrupt).T = Null_Task
1152 then
1153 -- No handler is attached. Unmask the Interrupt so that
1154 -- the default action can be carried out.
1156 IMOP.Thread_Unblock_Interrupt
1157 (IMNG.Interrupt_ID (Interrupt));
1159 else
1160 -- The Server_Task must be waiting on the Cond variable
1161 -- since it was being blocked and an Interrupt Hander or
1162 -- an Entry was there. Wake it up and let it change it
1163 -- place of waiting according to its new state.
1165 POP.Wakeup (Server_ID (Interrupt),
1166 Interrupt_Server_Blocked_Interrupt_Sleep);
1167 end if;
1168 end Unblock_Interrupt;
1171 accept Ignore_Interrupt (Interrupt : Interrupt_ID) do
1172 if Ignored (Interrupt) then
1173 return;
1174 end if;
1176 Ignored (Interrupt) := True;
1178 -- If there is a handler associated with the Interrupt,
1179 -- detach it first. In this way we make sure that the
1180 -- Server_Task is not on sigwait. This is legal since
1181 -- Unignore_Interrupt is to install the default action.
1183 if User_Handler (Interrupt).H /= null then
1184 Unprotected_Detach_Handler
1185 (Interrupt => Interrupt, Static => True);
1187 elsif User_Entry (Interrupt).T /= Null_Task then
1188 User_Entry (Interrupt) := Entry_Assoc'
1189 (T => Null_Task, E => Null_Task_Entry);
1190 Unbind_Handler (Interrupt);
1191 end if;
1193 IMOP.Install_Ignore_Action (IMNG.Interrupt_ID (Interrupt));
1194 end Ignore_Interrupt;
1197 accept Unignore_Interrupt (Interrupt : Interrupt_ID) do
1198 Ignored (Interrupt) := False;
1200 -- If there is a handler associated with the Interrupt,
1201 -- detach it first. In this way we make sure that the
1202 -- Server_Task is not on sigwait. This is legal since
1203 -- Unignore_Interrupt is to install the default action.
1205 if User_Handler (Interrupt).H /= null then
1206 Unprotected_Detach_Handler
1207 (Interrupt => Interrupt, Static => True);
1209 elsif User_Entry (Interrupt).T /= Null_Task then
1210 User_Entry (Interrupt) := Entry_Assoc'
1211 (T => Null_Task, E => Null_Task_Entry);
1212 Unbind_Handler (Interrupt);
1213 end if;
1215 IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt));
1216 end Unignore_Interrupt;
1217 end select;
1219 exception
1220 -- If there is a program error we just want to propagate it to
1221 -- the caller and do not want to stop this task.
1223 when Program_Error =>
1224 null;
1226 when X : others =>
1227 System.IO.Put_Line ("Exception in Interrupt_Manager");
1228 System.IO.Put_Line (Ada.Exceptions.Exception_Information (X));
1229 pragma Assert (False);
1230 end;
1231 end loop;
1232 end Interrupt_Manager;
1234 -----------------
1235 -- Server_Task --
1236 -----------------
1238 task body Server_Task is
1239 -- By making this task independent of master, when the process goes
1240 -- away, the Server_Task will terminate gracefully.
1242 Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent;
1244 Intwait_Mask : aliased IMNG.Interrupt_Mask;
1245 Ret_Interrupt : Interrupt_ID;
1246 Self_ID : constant Task_Id := Self;
1247 Tmp_Handler : Parameterless_Handler;
1248 Tmp_ID : Task_Id;
1249 Tmp_Entry_Index : Task_Entry_Index;
1251 begin
1252 -- Install default action in system level
1254 IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt));
1256 -- Note: All tasks in RTS will have all the Reserve Interrupts being
1257 -- masked (except the Interrupt_Manager) and Keep_Unmasked unmasked when
1258 -- created.
1260 -- Abort_Task_Interrupt is one of the Interrupt unmasked in all tasks.
1261 -- We mask the Interrupt in this particular task so that "sigwait" is
1262 -- possible to catch an explicitly sent Abort_Task_Interrupt from the
1263 -- Interrupt_Manager.
1265 -- There are two Interrupt interrupts that this task catch through
1266 -- "sigwait." One is the Interrupt this task is designated to catch
1267 -- in order to execute user handler or entry. The other one is
1268 -- the Abort_Task_Interrupt. This interrupt is being sent from the
1269 -- Interrupt_Manager to inform status changes (e.g: become Blocked,
1270 -- Handler or Entry is to be detached).
1272 -- Prepare a mask to used for sigwait
1274 IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access);
1276 IMOP.Add_To_Interrupt_Mask
1277 (Intwait_Mask'Access, IMNG.Interrupt_ID (Interrupt));
1279 IMOP.Add_To_Interrupt_Mask
1280 (Intwait_Mask'Access, IMNG.Abort_Task_Interrupt);
1282 IMOP.Thread_Block_Interrupt
1283 (IMNG.Abort_Task_Interrupt);
1285 PIO.Set_Interrupt_ID (IMNG.Interrupt_ID (Interrupt), Self_ID);
1287 loop
1288 System.Tasking.Initialization.Defer_Abort (Self_ID);
1290 if Single_Lock then
1291 POP.Lock_RTS;
1292 end if;
1294 POP.Write_Lock (Self_ID);
1296 if User_Handler (Interrupt).H = null
1297 and then User_Entry (Interrupt).T = Null_Task
1298 then
1299 -- No Interrupt binding. If there is an interrupt,
1300 -- Interrupt_Manager will take default action.
1302 Self_ID.Common.State := Interrupt_Server_Blocked_Interrupt_Sleep;
1303 POP.Sleep (Self_ID, Interrupt_Server_Idle_Sleep);
1304 Self_ID.Common.State := Runnable;
1306 elsif Blocked (Interrupt) then
1308 -- Interrupt is blocked, stay here, so we won't catch it
1310 Self_ID.Common.State := Interrupt_Server_Blocked_Interrupt_Sleep;
1311 POP.Sleep (Self_ID, Interrupt_Server_Blocked_Interrupt_Sleep);
1312 Self_ID.Common.State := Runnable;
1314 else
1315 -- A Handler or an Entry is installed. At this point all tasks
1316 -- mask for the Interrupt is masked. Catch the Interrupt using
1317 -- sigwait.
1319 -- This task may wake up from sigwait by receiving an interrupt
1320 -- (Abort_Task_Interrupt) from the Interrupt_Manager for unbinding
1321 -- a Procedure Handler or an Entry. Or it could be a wake up
1322 -- from status change (Unblocked -> Blocked). If that is not
1323 -- the case, we should execute the attached Procedure or Entry.
1325 Self_ID.Common.State := Interrupt_Server_Blocked_On_Event_Flag;
1326 POP.Unlock (Self_ID);
1328 if Single_Lock then
1329 POP.Unlock_RTS;
1330 end if;
1332 -- Avoid race condition when terminating application and
1333 -- System.Parameters.No_Abort is True.
1335 if Parameters.No_Abort and then Self_ID.Pending_Action then
1336 Initialization.Do_Pending_Action (Self_ID);
1337 end if;
1339 Ret_Interrupt :=
1340 Interrupt_ID (IMOP.Interrupt_Wait (Intwait_Mask'Access));
1341 Self_ID.Common.State := Runnable;
1343 if Ret_Interrupt = Interrupt_ID (IMNG.Abort_Task_Interrupt) then
1345 -- Inform the Interrupt_Manager of wakeup from above sigwait
1347 POP.Abort_Task (Interrupt_Manager_ID);
1349 if Single_Lock then
1350 POP.Lock_RTS;
1351 end if;
1353 POP.Write_Lock (Self_ID);
1355 else
1356 if Single_Lock then
1357 POP.Lock_RTS;
1358 end if;
1360 POP.Write_Lock (Self_ID);
1362 if Ret_Interrupt /= Interrupt then
1364 -- On some systems (e.g. recent linux kernels), sigwait
1365 -- may return unexpectedly (with errno set to EINTR).
1367 null;
1369 else
1370 -- Even though we have received an Interrupt the status may
1371 -- have changed already before we got the Self_ID lock above
1372 -- Therefore we make sure a Handler or an Entry is still
1373 -- there and make appropriate call.
1375 -- If there is no calls to make we need to regenerate the
1376 -- Interrupt in order not to lose it.
1378 if User_Handler (Interrupt).H /= null then
1379 Tmp_Handler := User_Handler (Interrupt).H;
1381 -- RTS calls should not be made with self being locked
1383 POP.Unlock (Self_ID);
1385 if Single_Lock then
1386 POP.Unlock_RTS;
1387 end if;
1389 Tmp_Handler.all;
1391 if Single_Lock then
1392 POP.Lock_RTS;
1393 end if;
1395 POP.Write_Lock (Self_ID);
1397 elsif User_Entry (Interrupt).T /= Null_Task then
1398 Tmp_ID := User_Entry (Interrupt).T;
1399 Tmp_Entry_Index := User_Entry (Interrupt).E;
1401 -- RTS calls should not be made with self being locked
1403 if Single_Lock then
1404 POP.Unlock_RTS;
1405 end if;
1407 POP.Unlock (Self_ID);
1409 System.Tasking.Rendezvous.Call_Simple
1410 (Tmp_ID, Tmp_Entry_Index, System.Null_Address);
1412 POP.Write_Lock (Self_ID);
1414 if Single_Lock then
1415 POP.Lock_RTS;
1416 end if;
1418 else
1419 -- This is a situation that this task wakes up receiving
1420 -- an Interrupt and before it gets the lock the Interrupt
1421 -- is blocked. We do not want to lose the interrupt in
1422 -- this case so we regenerate the Interrupt to process
1423 -- level.
1425 IMOP.Interrupt_Self_Process
1426 (IMNG.Interrupt_ID (Interrupt));
1427 end if;
1428 end if;
1429 end if;
1430 end if;
1432 POP.Unlock (Self_ID);
1434 if Single_Lock then
1435 POP.Unlock_RTS;
1436 end if;
1438 System.Tasking.Initialization.Undefer_Abort (Self_ID);
1440 if Self_ID.Pending_Action then
1441 Initialization.Do_Pending_Action (Self_ID);
1442 end if;
1444 -- Undefer abort here to allow a window for this task to be aborted
1445 -- at the time of system shutdown. We also explicitly test for
1446 -- Pending_Action in case System.Parameters.No_Abort is True.
1448 end loop;
1449 end Server_Task;
1451 -- Elaboration code for package System.Interrupts
1453 begin
1454 -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent
1456 Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity);
1458 -- During the elaboration of this package body we want the RTS
1459 -- to inherit the interrupt mask from the Environment Task.
1461 IMOP.Setup_Interrupt_Mask;
1463 -- The environment task should have gotten its mask from the enclosing
1464 -- process during the RTS start up. (See processing in s-inmaop.adb). Pass
1465 -- the Interrupt_Mask of the environment task to the Interrupt_Manager.
1467 -- Note: At this point we know that all tasks are masked for non-reserved
1468 -- signals. Only the Interrupt_Manager will have masks set up differently
1469 -- inheriting the original environment task's mask.
1471 Interrupt_Manager.Initialize (IMOP.Environment_Mask);
1472 end System.Interrupts;