1 ------------------------------------------------------------------------------
3 -- GNAT 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) 1992-2013, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
30 ------------------------------------------------------------------------------
34 -- All user-handleable interrupts are masked at all times in all
35 -- tasks/threads except possibly for the Interrupt_Manager task.
37 -- When a user task wants to have the effect of masking/unmasking an
38 -- interrupt, it must call Block_Interrupt/Unblock_Interrupt, which
39 -- will have the effect of unmasking/masking the interrupt in the
40 -- Interrupt_Manager task.
42 -- Note : Direct calls to sigaction, sigprocmask, pthread_sigsetmask or any
43 -- other low-level interface that changes the interrupt action or
44 -- 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
50 -- goes away, and we never remove the association.
52 -- There is no more than one interrupt per Server_Task and no more than
53 -- one Server_Task per interrupt.
55 with Ada.Task_Identification;
57 with System.Task_Primitives;
58 with System.Interrupt_Management;
60 with System.Interrupt_Management.Operations;
61 pragma Elaborate_All (System.Interrupt_Management.Operations);
63 with System.Task_Primitives.Operations;
64 with System.Task_Primitives.Interrupt_Operations;
65 with System.Storage_Elements;
66 with System.Tasking.Utilities;
68 with System.Tasking.Rendezvous;
69 pragma Elaborate_All (System.Tasking.Rendezvous);
71 with System.Tasking.Initialization;
72 with System.Parameters;
74 with Ada.Unchecked_Conversion;
76 package body System.Interrupts is
81 package POP renames System.Task_Primitives.Operations;
82 package PIO renames System.Task_Primitives.Interrupt_Operations;
83 package IMNG renames System.Interrupt_Management;
84 package IMOP renames System.Interrupt_Management.Operations;
86 function To_System is new Ada.Unchecked_Conversion
87 (Ada.Task_Identification.Task_Id, Task_Id);
93 -- WARNING: System.Tasking.Stages performs calls to this task with
94 -- low-level constructs. Do not change this spec without synchronizing it.
96 task Interrupt_Manager is
97 entry Detach_Interrupt_Entries (T : Task_Id);
99 entry Initialize (Mask : IMNG.Interrupt_Mask);
102 (New_Handler : Parameterless_Handler;
103 Interrupt : Interrupt_ID;
105 Restoration : Boolean := False);
107 entry Exchange_Handler
108 (Old_Handler : out Parameterless_Handler;
109 New_Handler : Parameterless_Handler;
110 Interrupt : Interrupt_ID;
114 (Interrupt : Interrupt_ID;
117 entry Bind_Interrupt_To_Entry
119 E : Task_Entry_Index;
120 Interrupt : Interrupt_ID);
122 entry Block_Interrupt (Interrupt : Interrupt_ID);
124 entry Unblock_Interrupt (Interrupt : Interrupt_ID);
126 entry Ignore_Interrupt (Interrupt : Interrupt_ID);
128 entry Unignore_Interrupt (Interrupt : Interrupt_ID);
130 pragma Interrupt_Priority (System.Interrupt_Priority'Last);
131 end Interrupt_Manager;
133 task type Server_Task (Interrupt : Interrupt_ID) is
134 pragma Priority (System.Interrupt_Priority'Last);
135 -- Note: the above pragma Priority is strictly speaking improper since
136 -- it is outside the range of allowed priorities, but the compiler
137 -- treats system units specially and does not apply this range checking
138 -- rule to system units.
142 type Server_Task_Access is access Server_Task;
144 -------------------------------
145 -- Local Types and Variables --
146 -------------------------------
148 type Entry_Assoc is record
150 E : Task_Entry_Index;
153 type Handler_Assoc is record
154 H : Parameterless_Handler;
155 Static : Boolean; -- Indicates static binding;
158 User_Handler : array (Interrupt_ID'Range) of Handler_Assoc :=
159 (others => (null, Static => False));
160 pragma Volatile_Components (User_Handler);
161 -- Holds the protected procedure handler (if any) and its Static
162 -- information for each interrupt. A handler is a Static one if it is
163 -- specified through the pragma Attach_Handler. Attach_Handler. Otherwise,
166 User_Entry : array (Interrupt_ID'Range) of Entry_Assoc :=
167 (others => (T => Null_Task, E => Null_Task_Entry));
168 pragma Volatile_Components (User_Entry);
169 -- Holds the task and entry index (if any) for each interrupt
171 Blocked : array (Interrupt_ID'Range) of Boolean := (others => False);
172 pragma Atomic_Components (Blocked);
173 -- True iff the corresponding interrupt is blocked in the process level
175 Ignored : array (Interrupt_ID'Range) of Boolean := (others => False);
176 pragma Atomic_Components (Ignored);
177 -- True iff the corresponding interrupt is blocked in the process level
180 array (Interrupt_ID'Range) of Task_Id := (others => Null_Task);
181 pragma Atomic_Components (Last_Unblocker);
182 -- Holds the ID of the last Task which Unblocked this Interrupt. It
183 -- contains Null_Task if no tasks have ever requested the Unblocking
184 -- operation or the Interrupt is currently Blocked.
186 Server_ID : array (Interrupt_ID'Range) of Task_Id :=
187 (others => Null_Task);
188 pragma Atomic_Components (Server_ID);
189 -- Holds the Task_Id of the Server_Task for each interrupt. Task_Id is
190 -- needed to accomplish locking per Interrupt base. Also is needed to
191 -- decide whether to create a new Server_Task.
193 -- Type and Head, Tail of the list containing Registered Interrupt
194 -- Handlers. These definitions are used to register the handlers
195 -- specified by the pragma Interrupt_Handler.
197 type Registered_Handler;
198 type R_Link is access all Registered_Handler;
200 type Registered_Handler is record
201 H : System.Address := System.Null_Address;
202 Next : R_Link := null;
205 Registered_Handler_Head : R_Link := null;
206 Registered_Handler_Tail : R_Link := null;
208 Access_Hold : Server_Task_Access;
209 -- Variable used to allocate Server_Task using "new"
211 -----------------------
212 -- Local Subprograms --
213 -----------------------
215 function Is_Registered (Handler : Parameterless_Handler) return Boolean;
216 -- See if the Handler has been "pragma"ed using Interrupt_Handler. Always
217 -- consider a null handler as registered.
223 -- Calling this procedure with New_Handler = null and Static = True means
224 -- we want to detach the current handler regardless of the previous
225 -- handler's binding status (i.e. do not care if it is a dynamic or static
228 -- This option is needed so that during the finalization of a PO, we can
229 -- detach handlers attached through pragma Attach_Handler.
231 procedure Attach_Handler
232 (New_Handler : Parameterless_Handler;
233 Interrupt : Interrupt_ID;
234 Static : Boolean := False)
237 if Is_Reserved (Interrupt) then
238 raise Program_Error with
239 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
242 Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static);
246 -----------------------------
247 -- Bind_Interrupt_To_Entry --
248 -----------------------------
250 -- This procedure raises a Program_Error if it tries to bind an interrupt
251 -- to which an Entry or a Procedure is already bound.
253 procedure Bind_Interrupt_To_Entry
255 E : Task_Entry_Index;
256 Int_Ref : System.Address)
258 Interrupt : constant Interrupt_ID :=
259 Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
262 if Is_Reserved (Interrupt) then
263 raise Program_Error with
264 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
267 Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt);
268 end Bind_Interrupt_To_Entry;
270 ---------------------
271 -- Block_Interrupt --
272 ---------------------
274 procedure Block_Interrupt (Interrupt : Interrupt_ID) is
276 if Is_Reserved (Interrupt) then
277 raise Program_Error with
278 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
281 Interrupt_Manager.Block_Interrupt (Interrupt);
284 ---------------------
285 -- Current_Handler --
286 ---------------------
288 function Current_Handler
289 (Interrupt : Interrupt_ID) return Parameterless_Handler
292 if Is_Reserved (Interrupt) then
293 raise Program_Error with
294 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
297 -- ??? Since Parameterless_Handler is not Atomic, the current
298 -- implementation is wrong. We need a new service in Interrupt_Manager
299 -- to ensure atomicity.
301 return User_Handler (Interrupt).H;
308 -- Calling this procedure with Static = True means we want to Detach the
309 -- current handler regardless of the previous handler's binding status
310 -- (i.e. do not care if it is a dynamic or static handler).
312 -- This option is needed so that during the finalization of a PO, we can
313 -- detach handlers attached through pragma Attach_Handler.
315 procedure Detach_Handler
316 (Interrupt : Interrupt_ID;
317 Static : Boolean := False)
320 if Is_Reserved (Interrupt) then
321 raise Program_Error with
322 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
325 Interrupt_Manager.Detach_Handler (Interrupt, Static);
328 ------------------------------
329 -- Detach_Interrupt_Entries --
330 ------------------------------
332 procedure Detach_Interrupt_Entries (T : Task_Id) is
334 Interrupt_Manager.Detach_Interrupt_Entries (T);
335 end Detach_Interrupt_Entries;
337 ----------------------
338 -- Exchange_Handler --
339 ----------------------
341 -- Calling this procedure with New_Handler = null and Static = True means
342 -- we want to detach the current handler regardless of the previous
343 -- handler's binding status (i.e. do not care if it is a dynamic or static
346 -- This option is needed so that during the finalization of a PO, we can
347 -- detach handlers attached through pragma Attach_Handler.
349 procedure Exchange_Handler
350 (Old_Handler : out Parameterless_Handler;
351 New_Handler : Parameterless_Handler;
352 Interrupt : Interrupt_ID;
353 Static : Boolean := False)
356 if Is_Reserved (Interrupt) then
357 raise Program_Error with
358 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
361 Interrupt_Manager.Exchange_Handler
362 (Old_Handler, New_Handler, Interrupt, Static);
363 end Exchange_Handler;
369 procedure Finalize (Object : in out Static_Interrupt_Protection) is
371 (Int : System.Interrupt_Management.Interrupt_ID) return Character;
372 pragma Import (C, State, "__gnat_get_interrupt_state");
373 -- Get interrupt state for interrupt number Int. Defined in init.c
375 Default : constant Character := 's';
376 -- 's' Interrupt_State pragma set state to System (use "default"
380 -- ??? loop to be executed only when we're not doing library level
381 -- finalization, since in this case all interrupt tasks are gone.
383 -- If the Abort_Task signal is set to system, it means that we cannot
384 -- reset interrupt handlers since this would require sending the abort
385 -- signal to the Server_Task
387 if not Interrupt_Manager'Terminated
388 and then State (System.Interrupt_Management.Abort_Task_Interrupt)
391 for N in reverse Object.Previous_Handlers'Range loop
392 Interrupt_Manager.Attach_Handler
393 (New_Handler => Object.Previous_Handlers (N).Handler,
394 Interrupt => Object.Previous_Handlers (N).Interrupt,
395 Static => Object.Previous_Handlers (N).Static,
396 Restoration => True);
400 Tasking.Protected_Objects.Entries.Finalize
401 (Tasking.Protected_Objects.Entries.Protection_Entries (Object));
404 -------------------------------------
405 -- Has_Interrupt_Or_Attach_Handler --
406 -------------------------------------
408 -- Need comments as to why these always return True ???
410 function Has_Interrupt_Or_Attach_Handler
411 (Object : access Dynamic_Interrupt_Protection) return Boolean
413 pragma Unreferenced (Object);
416 end Has_Interrupt_Or_Attach_Handler;
418 function Has_Interrupt_Or_Attach_Handler
419 (Object : access Static_Interrupt_Protection) return Boolean
421 pragma Unreferenced (Object);
424 end Has_Interrupt_Or_Attach_Handler;
426 ----------------------
427 -- Ignore_Interrupt --
428 ----------------------
430 procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
432 if Is_Reserved (Interrupt) then
433 raise Program_Error with
434 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
437 Interrupt_Manager.Ignore_Interrupt (Interrupt);
438 end Ignore_Interrupt;
440 ----------------------
441 -- Install_Handlers --
442 ----------------------
444 procedure Install_Handlers
445 (Object : access Static_Interrupt_Protection;
446 New_Handlers : New_Handler_Array)
449 for N in New_Handlers'Range loop
451 -- We need a lock around this ???
453 Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt;
454 Object.Previous_Handlers (N).Static := User_Handler
455 (New_Handlers (N).Interrupt).Static;
457 -- We call Exchange_Handler and not directly Interrupt_Manager.
458 -- Exchange_Handler so we get the Is_Reserved check.
461 (Old_Handler => Object.Previous_Handlers (N).Handler,
462 New_Handler => New_Handlers (N).Handler,
463 Interrupt => New_Handlers (N).Interrupt,
466 end Install_Handlers;
468 ---------------------------------
469 -- Install_Restricted_Handlers --
470 ---------------------------------
472 procedure Install_Restricted_Handlers
473 (Prio : Any_Priority;
474 Handlers : New_Handler_Array)
476 pragma Unreferenced (Prio);
478 for N in Handlers'Range loop
479 Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True);
481 end Install_Restricted_Handlers;
487 function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
489 if Is_Reserved (Interrupt) then
490 raise Program_Error with
491 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
494 return Blocked (Interrupt);
497 -----------------------
498 -- Is_Entry_Attached --
499 -----------------------
501 function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
503 if Is_Reserved (Interrupt) then
504 raise Program_Error with
505 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
508 return User_Entry (Interrupt).T /= Null_Task;
509 end Is_Entry_Attached;
511 -------------------------
512 -- Is_Handler_Attached --
513 -------------------------
515 function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
517 if Is_Reserved (Interrupt) then
518 raise Program_Error with
519 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
522 return User_Handler (Interrupt).H /= null;
523 end Is_Handler_Attached;
529 function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
531 if Is_Reserved (Interrupt) then
532 raise Program_Error with
533 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
536 return Ignored (Interrupt);
543 function Is_Registered (Handler : Parameterless_Handler) return Boolean is
545 type Fat_Ptr is record
546 Object_Addr : System.Address;
547 Handler_Addr : System.Address;
550 function To_Fat_Ptr is new Ada.Unchecked_Conversion
551 (Parameterless_Handler, Fat_Ptr);
557 if Handler = null then
561 Fat := To_Fat_Ptr (Handler);
563 Ptr := Registered_Handler_Head;
565 while Ptr /= null loop
566 if Ptr.H = Fat.Handler_Addr then
580 function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
582 return IMNG.Reserve (IMNG.Interrupt_ID (Interrupt));
589 function Reference (Interrupt : Interrupt_ID) return System.Address is
591 if Is_Reserved (Interrupt) then
592 raise Program_Error with
593 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
596 return Storage_Elements.To_Address
597 (Storage_Elements.Integer_Address (Interrupt));
600 ---------------------------------
601 -- Register_Interrupt_Handler --
602 ---------------------------------
604 procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is
605 New_Node_Ptr : R_Link;
608 -- This routine registers the Handler as usable for Dynamic Interrupt
609 -- Handler. Routines attaching and detaching Handler dynamically should
610 -- first consult if the Handler is registered. A Program Error should
611 -- be raised if it is not registered.
613 -- The pragma Interrupt_Handler can only appear in the library level PO
614 -- definition and instantiation. Therefore, we do not need to implement
615 -- Unregistering operation. Neither we need to protect the queue
616 -- structure using a Lock.
618 pragma Assert (Handler_Addr /= System.Null_Address);
620 New_Node_Ptr := new Registered_Handler;
621 New_Node_Ptr.H := Handler_Addr;
623 if Registered_Handler_Head = null then
624 Registered_Handler_Head := New_Node_Ptr;
625 Registered_Handler_Tail := New_Node_Ptr;
628 Registered_Handler_Tail.Next := New_Node_Ptr;
629 Registered_Handler_Tail := New_Node_Ptr;
631 end Register_Interrupt_Handler;
633 -----------------------
634 -- Unblock_Interrupt --
635 -----------------------
637 procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
639 if Is_Reserved (Interrupt) then
640 raise Program_Error with
641 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
644 Interrupt_Manager.Unblock_Interrupt (Interrupt);
645 end Unblock_Interrupt;
651 function Unblocked_By
652 (Interrupt : Interrupt_ID) return System.Tasking.Task_Id
655 if Is_Reserved (Interrupt) then
656 raise Program_Error with
657 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
660 return Last_Unblocker (Interrupt);
663 ------------------------
664 -- Unignore_Interrupt --
665 ------------------------
667 procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
669 if Is_Reserved (Interrupt) then
670 raise Program_Error with
671 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
674 Interrupt_Manager.Unignore_Interrupt (Interrupt);
675 end Unignore_Interrupt;
677 -----------------------
678 -- Interrupt_Manager --
679 -----------------------
681 task body Interrupt_Manager is
683 ---------------------
684 -- Local Variables --
685 ---------------------
687 Intwait_Mask : aliased IMNG.Interrupt_Mask;
688 Ret_Interrupt : Interrupt_ID;
689 Old_Mask : aliased IMNG.Interrupt_Mask;
690 Old_Handler : Parameterless_Handler;
696 procedure Bind_Handler (Interrupt : Interrupt_ID);
697 -- This procedure does not do anything if the Interrupt is blocked.
698 -- Otherwise, we have to interrupt Server_Task for status change through
701 procedure Unbind_Handler (Interrupt : Interrupt_ID);
702 -- This procedure does not do anything if the Interrupt is blocked.
703 -- Otherwise, we have to interrupt Server_Task for status change
704 -- through abort interrupt.
706 procedure Unprotected_Exchange_Handler
707 (Old_Handler : out Parameterless_Handler;
708 New_Handler : Parameterless_Handler;
709 Interrupt : Interrupt_ID;
711 Restoration : Boolean := False);
713 procedure Unprotected_Detach_Handler
714 (Interrupt : Interrupt_ID;
721 procedure Bind_Handler (Interrupt : Interrupt_ID) is
723 if not Blocked (Interrupt) then
725 -- Mask this task for the given Interrupt so that all tasks
726 -- are masked for the Interrupt and the actual delivery of the
727 -- Interrupt will be caught using "sigwait" by the
728 -- corresponding Server_Task.
730 IMOP.Thread_Block_Interrupt (IMNG.Interrupt_ID (Interrupt));
732 -- We have installed a Handler or an Entry before we called
733 -- this procedure. If the Handler Task is waiting to be awakened,
734 -- do it here. Otherwise, the interrupt will be discarded.
736 POP.Wakeup (Server_ID (Interrupt), Interrupt_Server_Idle_Sleep);
744 procedure Unbind_Handler (Interrupt : Interrupt_ID) is
745 Server : System.Tasking.Task_Id;
747 if not Blocked (Interrupt) then
748 -- Currently, there is a Handler or an Entry attached and
749 -- corresponding Server_Task is waiting on "sigwait."
750 -- We have to wake up the Server_Task and make it
751 -- wait on condition variable by sending an
752 -- Abort_Task_Interrupt
754 Server := Server_ID (Interrupt);
756 case Server.Common.State is
757 when Interrupt_Server_Idle_Sleep |
758 Interrupt_Server_Blocked_Interrupt_Sleep
760 POP.Wakeup (Server, Server.Common.State);
762 when Interrupt_Server_Blocked_On_Event_Flag =>
763 POP.Abort_Task (Server);
765 -- Make sure corresponding Server_Task is out of its
766 -- own sigwait state.
769 Interrupt_ID (IMOP.Interrupt_Wait (Intwait_Mask'Access));
771 (Ret_Interrupt = Interrupt_ID (IMNG.Abort_Task_Interrupt));
777 pragma Assert (False);
781 IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt));
783 -- Unmake the Interrupt for this task in order to allow default
786 IMOP.Thread_Unblock_Interrupt (IMNG.Interrupt_ID (Interrupt));
789 IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt));
793 --------------------------------
794 -- Unprotected_Detach_Handler --
795 --------------------------------
797 procedure Unprotected_Detach_Handler
798 (Interrupt : Interrupt_ID;
801 Old_Handler : Parameterless_Handler;
804 if User_Entry (Interrupt).T /= Null_Task then
806 -- In case we have an Interrupt Entry installed.
807 -- raise a program error. (propagate it to the caller).
809 raise Program_Error with
810 "An interrupt entry is already installed";
813 -- Note : Static = True will pass the following check. That is the
814 -- case when we want to detach a handler regardless of the static
815 -- status of the current_Handler.
817 if not Static and then User_Handler (Interrupt).Static then
819 -- Tries to detach a static Interrupt Handler.
820 -- raise a program error.
822 raise Program_Error with
823 "Trying to detach a static Interrupt Handler";
826 -- The interrupt should no longer be ignored if
827 -- it was ever ignored.
829 Ignored (Interrupt) := False;
831 Old_Handler := User_Handler (Interrupt).H;
835 User_Handler (Interrupt).H := null;
836 User_Handler (Interrupt).Static := False;
838 if Old_Handler /= null then
839 Unbind_Handler (Interrupt);
841 end Unprotected_Detach_Handler;
843 ----------------------------------
844 -- Unprotected_Exchange_Handler --
845 ----------------------------------
847 procedure Unprotected_Exchange_Handler
848 (Old_Handler : out Parameterless_Handler;
849 New_Handler : Parameterless_Handler;
850 Interrupt : Interrupt_ID;
852 Restoration : Boolean := False)
855 if User_Entry (Interrupt).T /= Null_Task then
857 -- In case we have an Interrupt Entry already installed.
858 -- raise a program error. (propagate it to the caller).
860 raise Program_Error with
861 "An interrupt is already installed";
864 -- Note : A null handler with Static = True will pass the
865 -- following check. That is the case when we want to Detach a
866 -- handler regardless of the Static status of the current_Handler.
868 -- We don't check anything if Restoration is True, since we
869 -- may be detaching a static handler to restore a dynamic one.
871 if not Restoration and then not Static
873 -- Tries to overwrite a static Interrupt Handler with a
876 and then (User_Handler (Interrupt).Static
878 -- The new handler is not specified as an
879 -- Interrupt Handler by a pragma.
881 or else not Is_Registered (New_Handler))
883 raise Program_Error with
884 "Trying to overwrite a static Interrupt Handler with a " &
888 -- The interrupt should no longer be ignored if
889 -- it was ever ignored.
891 Ignored (Interrupt) := False;
893 -- Save the old handler
895 Old_Handler := User_Handler (Interrupt).H;
899 User_Handler (Interrupt).H := New_Handler;
901 if New_Handler = null then
903 -- The null handler means we are detaching the handler
905 User_Handler (Interrupt).Static := False;
908 User_Handler (Interrupt).Static := Static;
911 -- Invoke a corresponding Server_Task if not yet created.
912 -- Place Task_Id info in Server_ID array.
914 if Server_ID (Interrupt) = Null_Task then
916 -- When a new Server_Task is created, it should have its
917 -- signal mask set to the All_Tasks_Mask.
919 IMOP.Set_Interrupt_Mask
920 (IMOP.All_Tasks_Mask'Access, Old_Mask'Access);
921 Access_Hold := new Server_Task (Interrupt);
922 IMOP.Set_Interrupt_Mask (Old_Mask'Access);
924 Server_ID (Interrupt) := To_System (Access_Hold.all'Identity);
927 if New_Handler = null then
928 if Old_Handler /= null then
929 Unbind_Handler (Interrupt);
935 if Old_Handler = null then
936 Bind_Handler (Interrupt);
938 end Unprotected_Exchange_Handler;
940 -- Start of processing for Interrupt_Manager
943 -- By making this task independent of master, when the process
944 -- goes away, the Interrupt_Manager will terminate gracefully.
946 System.Tasking.Utilities.Make_Independent;
948 -- Environment task gets its own interrupt mask, saves it,
949 -- and then masks all interrupts except the Keep_Unmasked set.
951 -- During rendezvous, the Interrupt_Manager receives the old
952 -- interrupt mask of the environment task, and sets its own
953 -- interrupt mask to that value.
955 -- The environment task will call the entry of Interrupt_Manager some
956 -- during elaboration of the body of this package.
958 accept Initialize (Mask : IMNG.Interrupt_Mask) do
960 The_Mask : aliased IMNG.Interrupt_Mask;
963 IMOP.Copy_Interrupt_Mask (The_Mask, Mask);
964 IMOP.Set_Interrupt_Mask (The_Mask'Access);
968 -- Note: All tasks in RTS will have all the Reserve Interrupts
969 -- being masked (except the Interrupt_Manager) and Keep_Unmasked
970 -- unmasked when created.
972 -- Abort_Task_Interrupt is one of the Interrupt unmasked
973 -- in all tasks. We mask the Interrupt in this particular task
974 -- so that "sigwait" is possible to catch an explicitly sent
975 -- Abort_Task_Interrupt from the Server_Tasks.
977 -- This sigwaiting is needed so that we make sure a Server_Task is
978 -- out of its own sigwait state. This extra synchronization is
979 -- necessary to prevent following scenarios.
981 -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to the
982 -- Server_Task then changes its own interrupt mask (OS level).
983 -- If an interrupt (corresponding to the Server_Task) arrives
984 -- in the mean time we have the Interrupt_Manager unmasked and
985 -- the Server_Task waiting on sigwait.
987 -- 2) For unbinding handler, we install a default action in the
988 -- Interrupt_Manager. POSIX.1c states that the result of using
989 -- "sigwait" and "sigaction" simultaneously on the same interrupt
990 -- is undefined. Therefore, we need to be informed from the
991 -- Server_Task of the fact that the Server_Task is out of its
994 IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access);
995 IMOP.Add_To_Interrupt_Mask
996 (Intwait_Mask'Access, IMNG.Abort_Task_Interrupt);
997 IMOP.Thread_Block_Interrupt
998 (IMNG.Abort_Task_Interrupt);
1001 -- A block is needed to absorb Program_Error exception
1005 accept Attach_Handler
1006 (New_Handler : Parameterless_Handler;
1007 Interrupt : Interrupt_ID;
1009 Restoration : Boolean := False)
1011 Unprotected_Exchange_Handler
1012 (Old_Handler, New_Handler, Interrupt, Static, Restoration);
1016 accept Exchange_Handler
1017 (Old_Handler : out Parameterless_Handler;
1018 New_Handler : Parameterless_Handler;
1019 Interrupt : Interrupt_ID;
1022 Unprotected_Exchange_Handler
1023 (Old_Handler, New_Handler, Interrupt, Static);
1024 end Exchange_Handler;
1027 accept Detach_Handler
1028 (Interrupt : Interrupt_ID;
1031 Unprotected_Detach_Handler (Interrupt, Static);
1035 accept Bind_Interrupt_To_Entry
1037 E : Task_Entry_Index;
1038 Interrupt : Interrupt_ID)
1040 -- if there is a binding already (either a procedure or an
1041 -- entry), raise Program_Error (propagate it to the caller).
1043 if User_Handler (Interrupt).H /= null
1044 or else User_Entry (Interrupt).T /= Null_Task
1046 raise Program_Error with
1047 "A binding for this interrupt is already present";
1050 -- The interrupt should no longer be ignored if
1051 -- it was ever ignored.
1053 Ignored (Interrupt) := False;
1054 User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E);
1056 -- Indicate the attachment of Interrupt Entry in ATCB.
1057 -- This is need so that when an Interrupt Entry task
1058 -- terminates the binding can be cleaned. The call to
1059 -- unbinding must be made by the task before it terminates.
1061 T.Interrupt_Entry := True;
1063 -- Invoke a corresponding Server_Task if not yet created.
1064 -- Place Task_Id info in Server_ID array.
1066 if Server_ID (Interrupt) = Null_Task then
1068 -- When a new Server_Task is created, it should have its
1069 -- signal mask set to the All_Tasks_Mask.
1071 IMOP.Set_Interrupt_Mask
1072 (IMOP.All_Tasks_Mask'Access, Old_Mask'Access);
1073 Access_Hold := new Server_Task (Interrupt);
1074 IMOP.Set_Interrupt_Mask (Old_Mask'Access);
1075 Server_ID (Interrupt) :=
1076 To_System (Access_Hold.all'Identity);
1079 Bind_Handler (Interrupt);
1080 end Bind_Interrupt_To_Entry;
1083 accept Detach_Interrupt_Entries (T : Task_Id) do
1084 for J in Interrupt_ID'Range loop
1085 if not Is_Reserved (J) then
1086 if User_Entry (J).T = T then
1088 -- The interrupt should no longer be ignored if
1089 -- it was ever ignored.
1091 Ignored (J) := False;
1092 User_Entry (J) := Entry_Assoc'
1093 (T => Null_Task, E => Null_Task_Entry);
1099 -- Indicate in ATCB that no Interrupt Entries are attached
1101 T.Interrupt_Entry := False;
1102 end Detach_Interrupt_Entries;
1105 accept Block_Interrupt (Interrupt : Interrupt_ID) do
1106 if Blocked (Interrupt) then
1110 Blocked (Interrupt) := True;
1111 Last_Unblocker (Interrupt) := Null_Task;
1113 -- Mask this task for the given Interrupt so that all tasks
1114 -- are masked for the Interrupt.
1116 IMOP.Thread_Block_Interrupt (IMNG.Interrupt_ID (Interrupt));
1118 if User_Handler (Interrupt).H /= null
1119 or else User_Entry (Interrupt).T /= Null_Task
1121 -- This is the case where the Server_Task is waiting
1122 -- on "sigwait." Wake it up by sending an
1123 -- Abort_Task_Interrupt so that the Server_Task
1126 POP.Abort_Task (Server_ID (Interrupt));
1128 -- Make sure corresponding Server_Task is out of its own
1131 Ret_Interrupt := Interrupt_ID
1132 (IMOP.Interrupt_Wait (Intwait_Mask'Access));
1135 Interrupt_ID (IMNG.Abort_Task_Interrupt));
1137 end Block_Interrupt;
1140 accept Unblock_Interrupt (Interrupt : Interrupt_ID) do
1141 if not Blocked (Interrupt) then
1145 Blocked (Interrupt) := False;
1146 Last_Unblocker (Interrupt) :=
1147 To_System (Unblock_Interrupt'Caller);
1149 if User_Handler (Interrupt).H = null
1150 and then User_Entry (Interrupt).T = Null_Task
1152 -- No handler is attached. Unmask the Interrupt so that
1153 -- the default action can be carried out.
1155 IMOP.Thread_Unblock_Interrupt
1156 (IMNG.Interrupt_ID (Interrupt));
1159 -- The Server_Task must be waiting on the Cond variable
1160 -- since it was being blocked and an Interrupt Hander or
1161 -- an Entry was there. Wake it up and let it change
1162 -- it place of waiting according to its new state.
1164 POP.Wakeup (Server_ID (Interrupt),
1165 Interrupt_Server_Blocked_Interrupt_Sleep);
1167 end Unblock_Interrupt;
1170 accept Ignore_Interrupt (Interrupt : Interrupt_ID) do
1171 if Ignored (Interrupt) then
1175 Ignored (Interrupt) := True;
1177 -- If there is a handler associated with the Interrupt,
1178 -- detach it first. In this way we make sure that the
1179 -- Server_Task is not on sigwait. This is legal since
1180 -- Unignore_Interrupt is to install the default action.
1182 if User_Handler (Interrupt).H /= null then
1183 Unprotected_Detach_Handler
1184 (Interrupt => Interrupt, Static => True);
1186 elsif User_Entry (Interrupt).T /= Null_Task then
1187 User_Entry (Interrupt) := Entry_Assoc'
1188 (T => Null_Task, E => Null_Task_Entry);
1189 Unbind_Handler (Interrupt);
1192 IMOP.Install_Ignore_Action (IMNG.Interrupt_ID (Interrupt));
1193 end Ignore_Interrupt;
1196 accept Unignore_Interrupt (Interrupt : Interrupt_ID) do
1197 Ignored (Interrupt) := False;
1199 -- If there is a handler associated with the Interrupt,
1200 -- detach it first. In this way we make sure that the
1201 -- Server_Task is not on sigwait. This is legal since
1202 -- Unignore_Interrupt is to install the default action.
1204 if User_Handler (Interrupt).H /= null then
1205 Unprotected_Detach_Handler
1206 (Interrupt => Interrupt, Static => True);
1208 elsif User_Entry (Interrupt).T /= Null_Task then
1209 User_Entry (Interrupt) := Entry_Assoc'
1210 (T => Null_Task, E => Null_Task_Entry);
1211 Unbind_Handler (Interrupt);
1214 IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt));
1215 end Unignore_Interrupt;
1219 -- If there is a program error we just want to propagate it to
1220 -- the caller and do not want to stop this task.
1222 when Program_Error =>
1226 pragma Assert (False);
1230 end Interrupt_Manager;
1236 task body Server_Task is
1237 Intwait_Mask : aliased IMNG.Interrupt_Mask;
1238 Ret_Interrupt : Interrupt_ID;
1239 Self_ID : constant Task_Id := Self;
1240 Tmp_Handler : Parameterless_Handler;
1242 Tmp_Entry_Index : Task_Entry_Index;
1245 -- By making this task independent of master, when the process
1246 -- goes away, the Server_Task will terminate gracefully.
1248 System.Tasking.Utilities.Make_Independent;
1250 -- Install default action in system level
1252 IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt));
1254 -- Note: All tasks in RTS will have all the Reserve Interrupts being
1255 -- masked (except the Interrupt_Manager) and Keep_Unmasked unmasked when
1258 -- Abort_Task_Interrupt is one of the Interrupt unmasked in all tasks.
1259 -- We mask the Interrupt in this particular task so that "sigwait" is
1260 -- possible to catch an explicitly sent Abort_Task_Interrupt from the
1261 -- Interrupt_Manager.
1263 -- There are two Interrupt interrupts that this task catch through
1264 -- "sigwait." One is the Interrupt this task is designated to catch
1265 -- in order to execute user handler or entry. The other one is the
1266 -- Abort_Task_Interrupt. This interrupt is being sent from the
1267 -- Interrupt_Manager to inform status changes (e.g: become Blocked,
1268 -- Handler or Entry is to be detached).
1270 -- Prepare a mask to used for sigwait
1272 IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access);
1274 IMOP.Add_To_Interrupt_Mask
1275 (Intwait_Mask'Access, IMNG.Interrupt_ID (Interrupt));
1277 IMOP.Add_To_Interrupt_Mask
1278 (Intwait_Mask'Access, IMNG.Abort_Task_Interrupt);
1280 IMOP.Thread_Block_Interrupt
1281 (IMNG.Abort_Task_Interrupt);
1283 PIO.Set_Interrupt_ID (IMNG.Interrupt_ID (Interrupt), Self_ID);
1286 System.Tasking.Initialization.Defer_Abort (Self_ID);
1292 POP.Write_Lock (Self_ID);
1294 if User_Handler (Interrupt).H = null
1295 and then User_Entry (Interrupt).T = Null_Task
1297 -- No Interrupt binding. If there is an interrupt,
1298 -- Interrupt_Manager will take default action.
1300 Self_ID.Common.State := Interrupt_Server_Blocked_Interrupt_Sleep;
1301 POP.Sleep (Self_ID, Interrupt_Server_Idle_Sleep);
1302 Self_ID.Common.State := Runnable;
1304 elsif Blocked (Interrupt) then
1306 -- Interrupt is blocked. Stay here, so we won't catch
1309 Self_ID.Common.State := Interrupt_Server_Blocked_Interrupt_Sleep;
1310 POP.Sleep (Self_ID, Interrupt_Server_Blocked_Interrupt_Sleep);
1311 Self_ID.Common.State := Runnable;
1314 -- A Handler or an Entry is installed. At this point all tasks
1315 -- mask for the Interrupt is masked. Catch the Interrupt using
1318 -- This task may wake up from sigwait by receiving an interrupt
1319 -- (Abort_Task_Interrupt) from the Interrupt_Manager for unbinding
1320 -- a Procedure Handler or an Entry. Or it could be a wake up
1321 -- from status change (Unblocked -> Blocked). If that is not
1322 -- the case, we should execute the attached Procedure or Entry.
1324 Self_ID.Common.State := Interrupt_Server_Blocked_On_Event_Flag;
1325 POP.Unlock (Self_ID);
1331 -- Avoid race condition when terminating application and
1332 -- System.Parameters.No_Abort is True.
1334 if Parameters.No_Abort and then Self_ID.Pending_Action then
1335 Initialization.Do_Pending_Action (Self_ID);
1339 Interrupt_ID (IMOP.Interrupt_Wait (Intwait_Mask'Access));
1340 Self_ID.Common.State := Runnable;
1342 if Ret_Interrupt = Interrupt_ID (IMNG.Abort_Task_Interrupt) then
1344 -- Inform the Interrupt_Manager of wakeup from above sigwait
1346 POP.Abort_Task (Interrupt_Manager_ID);
1352 POP.Write_Lock (Self_ID);
1359 POP.Write_Lock (Self_ID);
1361 if Ret_Interrupt /= Interrupt then
1363 -- On some systems (e.g. recent linux kernels), sigwait
1364 -- may return unexpectedly (with errno set to EINTR).
1369 -- Even though we have received an Interrupt the status may
1370 -- have changed already before we got the Self_ID lock above
1371 -- Therefore we make sure a Handler or an Entry is still
1372 -- there and make appropriate call.
1374 -- If there is no calls to make we need to regenerate the
1375 -- Interrupt in order not to lose it.
1377 if User_Handler (Interrupt).H /= null then
1378 Tmp_Handler := User_Handler (Interrupt).H;
1380 -- RTS calls should not be made with self being locked
1382 POP.Unlock (Self_ID);
1394 POP.Write_Lock (Self_ID);
1396 elsif User_Entry (Interrupt).T /= Null_Task then
1397 Tmp_ID := User_Entry (Interrupt).T;
1398 Tmp_Entry_Index := User_Entry (Interrupt).E;
1400 -- RTS calls should not be made with self being locked
1406 POP.Unlock (Self_ID);
1408 System.Tasking.Rendezvous.Call_Simple
1409 (Tmp_ID, Tmp_Entry_Index, System.Null_Address);
1411 POP.Write_Lock (Self_ID);
1418 -- This is a situation that this task wakes up receiving
1419 -- an Interrupt and before it gets the lock the Interrupt
1420 -- is blocked. We do not want to lose the interrupt in
1421 -- this case so we regenerate the Interrupt to process
1424 IMOP.Interrupt_Self_Process
1425 (IMNG.Interrupt_ID (Interrupt));
1431 POP.Unlock (Self_ID);
1437 System.Tasking.Initialization.Undefer_Abort (Self_ID);
1439 if Self_ID.Pending_Action then
1440 Initialization.Do_Pending_Action (Self_ID);
1443 -- Undefer abort here to allow a window for this task to be aborted
1444 -- at the time of system shutdown. We also explicitly test for
1445 -- Pending_Action in case System.Parameters.No_Abort is True.
1450 -- Elaboration code for package System.Interrupts
1453 -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent
1455 Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity);
1457 -- During the elaboration of this package body we want the RTS
1458 -- to inherit the interrupt mask from the Environment Task.
1460 IMOP.Setup_Interrupt_Mask;
1462 -- The environment task should have gotten its mask from the enclosing
1463 -- process during the RTS start up. (See processing in s-inmaop.adb). Pass
1464 -- the Interrupt_Mask of the environment task to the Interrupt_Manager.
1466 -- Note: At this point we know that all tasks are masked for non-reserved
1467 -- signals. Only the Interrupt_Manager will have masks set up differently
1468 -- inheriting the original environment task's mask.
1470 Interrupt_Manager.Initialize (IMOP.Environment_Mask);
1471 end System.Interrupts;