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-2008, 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 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, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, 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 ------------------------------------------------------------------------------
36 -- All user-handleable interrupts are masked at all times in all
37 -- tasks/threads except possibly for the Interrupt_Manager task.
39 -- When a user task wants to have the effect of masking/unmasking an
40 -- interrupt, it must call Block_Interrupt/Unblock_Interrupt, which
41 -- will have the effect of unmasking/masking the interrupt in the
42 -- Interrupt_Manager task.
44 -- Note : Direct calls to sigaction, sigprocmask, pthread_sigsetmask or any
45 -- other low-level interface that changes the interrupt action or
46 -- interrupt mask needs a careful thought.
47 -- One may acheive the effect of system calls first masking RTS blocked
48 -- (by calling Block_Interrupt) for the interrupt under consideration.
49 -- This will make all the tasks in RTS blocked for the Interrupt.
51 -- Once we associate a Server_Task with an interrupt, the task never
52 -- goes away, and we never remove the association.
54 -- There is no more than one interrupt per Server_Task and no more than
55 -- one Server_Task per interrupt.
57 with Ada.Task_Identification;
59 with System.Task_Primitives;
60 with System.Interrupt_Management;
62 with System.Interrupt_Management.Operations;
63 pragma Elaborate_All (System.Interrupt_Management.Operations);
65 with System.Task_Primitives.Operations;
66 with System.Task_Primitives.Interrupt_Operations;
67 with System.Storage_Elements;
68 with System.Tasking.Utilities;
70 with System.Tasking.Rendezvous;
71 pragma Elaborate_All (System.Tasking.Rendezvous);
73 with System.Tasking.Initialization;
74 with System.Parameters;
76 with Ada.Unchecked_Conversion;
78 package body System.Interrupts is
83 package POP renames System.Task_Primitives.Operations;
84 package PIO renames System.Task_Primitives.Interrupt_Operations;
85 package IMNG renames System.Interrupt_Management;
86 package IMOP renames System.Interrupt_Management.Operations;
88 function To_System is new Ada.Unchecked_Conversion
89 (Ada.Task_Identification.Task_Id, Task_Id);
95 -- WARNING: System.Tasking.Stages performs calls to this task with
96 -- low-level constructs. Do not change this spec without synchronizing it.
98 task Interrupt_Manager is
99 entry Detach_Interrupt_Entries (T : Task_Id);
101 entry Initialize (Mask : IMNG.Interrupt_Mask);
104 (New_Handler : Parameterless_Handler;
105 Interrupt : Interrupt_ID;
107 Restoration : Boolean := False);
109 entry Exchange_Handler
110 (Old_Handler : out Parameterless_Handler;
111 New_Handler : Parameterless_Handler;
112 Interrupt : Interrupt_ID;
116 (Interrupt : Interrupt_ID;
119 entry Bind_Interrupt_To_Entry
121 E : Task_Entry_Index;
122 Interrupt : Interrupt_ID);
124 entry Block_Interrupt (Interrupt : Interrupt_ID);
126 entry Unblock_Interrupt (Interrupt : Interrupt_ID);
128 entry Ignore_Interrupt (Interrupt : Interrupt_ID);
130 entry Unignore_Interrupt (Interrupt : Interrupt_ID);
132 pragma Interrupt_Priority (System.Interrupt_Priority'Last);
133 end Interrupt_Manager;
135 task type Server_Task (Interrupt : Interrupt_ID) is
136 pragma Priority (System.Interrupt_Priority'Last);
137 -- Note: the above pragma Priority is strictly speaking improper since
138 -- it is outside the range of allowed priorities, but the compiler
139 -- treats system units specially and does not apply this range checking
140 -- rule to system units.
144 type Server_Task_Access is access Server_Task;
146 -------------------------------
147 -- Local Types and Variables --
148 -------------------------------
150 type Entry_Assoc is record
152 E : Task_Entry_Index;
155 type Handler_Assoc is record
156 H : Parameterless_Handler;
157 Static : Boolean; -- Indicates static binding;
160 User_Handler : array (Interrupt_ID'Range) of Handler_Assoc :=
161 (others => (null, Static => False));
162 pragma Volatile_Components (User_Handler);
163 -- Holds the protected procedure handler (if any) and its Static
164 -- information for each interrupt. A handler is a Static one if it is
165 -- specified through the pragma Attach_Handler. Attach_Handler. Otherwise,
168 User_Entry : array (Interrupt_ID'Range) of Entry_Assoc :=
169 (others => (T => Null_Task, E => Null_Task_Entry));
170 pragma Volatile_Components (User_Entry);
171 -- Holds the task and entry index (if any) for each interrupt
173 Blocked : array (Interrupt_ID'Range) of Boolean := (others => False);
174 pragma Atomic_Components (Blocked);
175 -- True iff the corresponding interrupt is blocked in the process level
177 Ignored : array (Interrupt_ID'Range) of Boolean := (others => False);
178 pragma Atomic_Components (Ignored);
179 -- True iff the corresponding interrupt is blocked in the process level
182 array (Interrupt_ID'Range) of Task_Id := (others => Null_Task);
183 pragma Atomic_Components (Last_Unblocker);
184 -- Holds the ID of the last Task which Unblocked this Interrupt. It
185 -- contains Null_Task if no tasks have ever requested the Unblocking
186 -- operation or the Interrupt is currently Blocked.
188 Server_ID : array (Interrupt_ID'Range) of Task_Id :=
189 (others => Null_Task);
190 pragma Atomic_Components (Server_ID);
191 -- Holds the Task_Id of the Server_Task for each interrupt. Task_Id is
192 -- needed to accomplish locking per Interrupt base. Also is needed to
193 -- decide whether to create a new Server_Task.
195 -- Type and Head, Tail of the list containing Registered Interrupt
196 -- Handlers. These definitions are used to register the handlers
197 -- specified by the pragma Interrupt_Handler.
199 type Registered_Handler;
200 type R_Link is access all Registered_Handler;
202 type Registered_Handler is record
203 H : System.Address := System.Null_Address;
204 Next : R_Link := null;
207 Registered_Handler_Head : R_Link := null;
208 Registered_Handler_Tail : R_Link := null;
210 Access_Hold : Server_Task_Access;
211 -- Variable used to allocate Server_Task using "new"
213 -----------------------
214 -- Local Subprograms --
215 -----------------------
217 function Is_Registered (Handler : Parameterless_Handler) return Boolean;
218 -- See if the Handler has been "pragma"ed using Interrupt_Handler. Always
219 -- consider a null handler as registered.
225 -- Calling this procedure with New_Handler = null and Static = True means
226 -- we want to detach the current handler regardless of the previous
227 -- handler's binding status (ie. do not care if it is a dynamic or static
230 -- This option is needed so that during the finalization of a PO, we can
231 -- detach handlers attached through pragma Attach_Handler.
233 procedure Attach_Handler
234 (New_Handler : Parameterless_Handler;
235 Interrupt : Interrupt_ID;
236 Static : Boolean := False)
239 if Is_Reserved (Interrupt) then
240 raise Program_Error with
241 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
244 Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static);
248 -----------------------------
249 -- Bind_Interrupt_To_Entry --
250 -----------------------------
252 -- This procedure raises a Program_Error if it tries to bind an interrupt
253 -- to which an Entry or a Procedure is already bound.
255 procedure Bind_Interrupt_To_Entry
257 E : Task_Entry_Index;
258 Int_Ref : System.Address)
260 Interrupt : constant Interrupt_ID :=
261 Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
264 if Is_Reserved (Interrupt) then
265 raise Program_Error with
266 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
269 Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt);
270 end Bind_Interrupt_To_Entry;
272 ---------------------
273 -- Block_Interrupt --
274 ---------------------
276 procedure Block_Interrupt (Interrupt : Interrupt_ID) is
278 if Is_Reserved (Interrupt) then
279 raise Program_Error with
280 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
283 Interrupt_Manager.Block_Interrupt (Interrupt);
286 ---------------------
287 -- Current_Handler --
288 ---------------------
290 function Current_Handler
291 (Interrupt : Interrupt_ID) return Parameterless_Handler
294 if Is_Reserved (Interrupt) then
295 raise Program_Error with
296 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
299 -- ??? Since Parameterless_Handler is not Atomic, the current
300 -- implementation is wrong. We need a new service in Interrupt_Manager
301 -- to ensure atomicity.
303 return User_Handler (Interrupt).H;
310 -- Calling this procedure with Static = True means we want to Detach the
311 -- current handler regardless of the previous handler's binding status
312 -- (i.e. do not care if it is a dynamic or static handler).
314 -- This option is needed so that during the finalization of a PO, we can
315 -- detach handlers attached through pragma Attach_Handler.
317 procedure Detach_Handler
318 (Interrupt : Interrupt_ID;
319 Static : Boolean := False)
322 if Is_Reserved (Interrupt) then
323 raise Program_Error with
324 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
327 Interrupt_Manager.Detach_Handler (Interrupt, Static);
330 ------------------------------
331 -- Detach_Interrupt_Entries --
332 ------------------------------
334 procedure Detach_Interrupt_Entries (T : Task_Id) is
336 Interrupt_Manager.Detach_Interrupt_Entries (T);
337 end Detach_Interrupt_Entries;
339 ----------------------
340 -- Exchange_Handler --
341 ----------------------
343 -- Calling this procedure with New_Handler = null and Static = True means
344 -- we want to detach the current handler regardless of the previous
345 -- handler's binding status (ie. do not care if it is a dynamic or static
348 -- This option is needed so that during the finalization of a PO, we can
349 -- detach handlers attached through pragma Attach_Handler.
351 procedure Exchange_Handler
352 (Old_Handler : out Parameterless_Handler;
353 New_Handler : Parameterless_Handler;
354 Interrupt : Interrupt_ID;
355 Static : Boolean := False)
358 if Is_Reserved (Interrupt) then
359 raise Program_Error with
360 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
363 Interrupt_Manager.Exchange_Handler
364 (Old_Handler, New_Handler, Interrupt, Static);
365 end Exchange_Handler;
371 procedure Finalize (Object : in out Static_Interrupt_Protection) is
373 -- ??? loop to be executed only when we're not doing library level
374 -- finalization, since in this case all interrupt tasks are gone.
376 if not Interrupt_Manager'Terminated then
377 for N in reverse Object.Previous_Handlers'Range loop
378 Interrupt_Manager.Attach_Handler
379 (New_Handler => Object.Previous_Handlers (N).Handler,
380 Interrupt => Object.Previous_Handlers (N).Interrupt,
381 Static => Object.Previous_Handlers (N).Static,
382 Restoration => True);
386 Tasking.Protected_Objects.Entries.Finalize
387 (Tasking.Protected_Objects.Entries.Protection_Entries (Object));
390 -------------------------------------
391 -- Has_Interrupt_Or_Attach_Handler --
392 -------------------------------------
394 -- Need comments as to why these always return True ???
396 function Has_Interrupt_Or_Attach_Handler
397 (Object : access Dynamic_Interrupt_Protection) return Boolean
399 pragma Unreferenced (Object);
402 end Has_Interrupt_Or_Attach_Handler;
404 function Has_Interrupt_Or_Attach_Handler
405 (Object : access Static_Interrupt_Protection) return Boolean
407 pragma Unreferenced (Object);
410 end Has_Interrupt_Or_Attach_Handler;
412 ----------------------
413 -- Ignore_Interrupt --
414 ----------------------
416 procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
418 if Is_Reserved (Interrupt) then
419 raise Program_Error with
420 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
423 Interrupt_Manager.Ignore_Interrupt (Interrupt);
424 end Ignore_Interrupt;
426 ----------------------
427 -- Install_Handlers --
428 ----------------------
430 procedure Install_Handlers
431 (Object : access Static_Interrupt_Protection;
432 New_Handlers : New_Handler_Array)
435 for N in New_Handlers'Range loop
437 -- We need a lock around this ???
439 Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt;
440 Object.Previous_Handlers (N).Static := User_Handler
441 (New_Handlers (N).Interrupt).Static;
443 -- We call Exchange_Handler and not directly Interrupt_Manager.
444 -- Exchange_Handler so we get the Is_Reserved check.
447 (Old_Handler => Object.Previous_Handlers (N).Handler,
448 New_Handler => New_Handlers (N).Handler,
449 Interrupt => New_Handlers (N).Interrupt,
452 end Install_Handlers;
458 function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
460 if Is_Reserved (Interrupt) then
461 raise Program_Error with
462 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
465 return Blocked (Interrupt);
468 -----------------------
469 -- Is_Entry_Attached --
470 -----------------------
472 function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
474 if Is_Reserved (Interrupt) then
475 raise Program_Error with
476 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
479 return User_Entry (Interrupt).T /= Null_Task;
480 end Is_Entry_Attached;
482 -------------------------
483 -- Is_Handler_Attached --
484 -------------------------
486 function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
488 if Is_Reserved (Interrupt) then
489 raise Program_Error with
490 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
493 return User_Handler (Interrupt).H /= null;
494 end Is_Handler_Attached;
500 function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
502 if Is_Reserved (Interrupt) then
503 raise Program_Error with
504 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
507 return Ignored (Interrupt);
514 function Is_Registered (Handler : Parameterless_Handler) return Boolean is
516 type Fat_Ptr is record
517 Object_Addr : System.Address;
518 Handler_Addr : System.Address;
521 function To_Fat_Ptr is new Ada.Unchecked_Conversion
522 (Parameterless_Handler, Fat_Ptr);
528 if Handler = null then
532 Fat := To_Fat_Ptr (Handler);
534 Ptr := Registered_Handler_Head;
536 while Ptr /= null loop
537 if Ptr.H = Fat.Handler_Addr then
551 function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
553 return IMNG.Reserve (IMNG.Interrupt_ID (Interrupt));
560 function Reference (Interrupt : Interrupt_ID) return System.Address is
562 if Is_Reserved (Interrupt) then
563 raise Program_Error with
564 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
567 return Storage_Elements.To_Address
568 (Storage_Elements.Integer_Address (Interrupt));
571 ---------------------------------
572 -- Register_Interrupt_Handler --
573 ---------------------------------
575 procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is
576 New_Node_Ptr : R_Link;
579 -- This routine registers the Handler as usable for Dynamic Interrupt
580 -- Handler. Routines attaching and detaching Handler dynamically should
581 -- first consult if the Handler is registered. A Program Error should
582 -- be raised if it is not registered.
584 -- The pragma Interrupt_Handler can only appear in the library level PO
585 -- definition and instantiation. Therefore, we do not need to implement
586 -- Unregistering operation. Neither we need to protect the queue
587 -- structure using a Lock.
589 pragma Assert (Handler_Addr /= System.Null_Address);
591 New_Node_Ptr := new Registered_Handler;
592 New_Node_Ptr.H := Handler_Addr;
594 if Registered_Handler_Head = null then
595 Registered_Handler_Head := New_Node_Ptr;
596 Registered_Handler_Tail := New_Node_Ptr;
599 Registered_Handler_Tail.Next := New_Node_Ptr;
600 Registered_Handler_Tail := New_Node_Ptr;
602 end Register_Interrupt_Handler;
604 -----------------------
605 -- Unblock_Interrupt --
606 -----------------------
608 procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
610 if Is_Reserved (Interrupt) then
611 raise Program_Error with
612 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
615 Interrupt_Manager.Unblock_Interrupt (Interrupt);
616 end Unblock_Interrupt;
622 function Unblocked_By
623 (Interrupt : Interrupt_ID) return System.Tasking.Task_Id
626 if Is_Reserved (Interrupt) then
627 raise Program_Error with
628 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
631 return Last_Unblocker (Interrupt);
634 ------------------------
635 -- Unignore_Interrupt --
636 ------------------------
638 procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
640 if Is_Reserved (Interrupt) then
641 raise Program_Error with
642 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
645 Interrupt_Manager.Unignore_Interrupt (Interrupt);
646 end Unignore_Interrupt;
648 -----------------------
649 -- Interrupt_Manager --
650 -----------------------
652 task body Interrupt_Manager is
654 ---------------------
655 -- Local Variables --
656 ---------------------
658 Intwait_Mask : aliased IMNG.Interrupt_Mask;
659 Ret_Interrupt : Interrupt_ID;
660 Old_Mask : aliased IMNG.Interrupt_Mask;
661 Old_Handler : Parameterless_Handler;
667 procedure Bind_Handler (Interrupt : Interrupt_ID);
668 -- This procedure does not do anything if the Interrupt is blocked.
669 -- Otherwise, we have to interrupt Server_Task for status change through
672 procedure Unbind_Handler (Interrupt : Interrupt_ID);
673 -- This procedure does not do anything if the Interrupt is blocked.
674 -- Otherwise, we have to interrupt Server_Task for status change
675 -- through abort interrupt.
677 procedure Unprotected_Exchange_Handler
678 (Old_Handler : out Parameterless_Handler;
679 New_Handler : Parameterless_Handler;
680 Interrupt : Interrupt_ID;
682 Restoration : Boolean := False);
684 procedure Unprotected_Detach_Handler
685 (Interrupt : Interrupt_ID;
692 procedure Bind_Handler (Interrupt : Interrupt_ID) is
694 if not Blocked (Interrupt) then
696 -- Mask this task for the given Interrupt so that all tasks
697 -- are masked for the Interrupt and the actuall delivery of the
698 -- Interrupt will be caught using "sigwait" by the
699 -- corresponding Server_Task.
701 IMOP.Thread_Block_Interrupt (IMNG.Interrupt_ID (Interrupt));
703 -- We have installed a Handler or an Entry before we called
704 -- this procedure. If the Handler Task is waiting to be awakened,
705 -- do it here. Otherwise, the interrupt will be discarded.
707 POP.Wakeup (Server_ID (Interrupt), Interrupt_Server_Idle_Sleep);
715 procedure Unbind_Handler (Interrupt : Interrupt_ID) is
716 Server : System.Tasking.Task_Id;
718 if not Blocked (Interrupt) then
719 -- Currently, there is a Handler or an Entry attached and
720 -- corresponding Server_Task is waiting on "sigwait."
721 -- We have to wake up the Server_Task and make it
722 -- wait on condition variable by sending an
723 -- Abort_Task_Interrupt
725 Server := Server_ID (Interrupt);
727 case Server.Common.State is
728 when Interrupt_Server_Idle_Sleep |
729 Interrupt_Server_Blocked_Interrupt_Sleep
731 POP.Wakeup (Server, Server.Common.State);
733 when Interrupt_Server_Blocked_On_Event_Flag =>
734 POP.Abort_Task (Server);
736 -- Make sure corresponding Server_Task is out of its
737 -- own sigwait state.
740 Interrupt_ID (IMOP.Interrupt_Wait (Intwait_Mask'Access));
742 (Ret_Interrupt = Interrupt_ID (IMNG.Abort_Task_Interrupt));
748 pragma Assert (False);
752 IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt));
754 -- Unmake the Interrupt for this task in order to allow default
757 IMOP.Thread_Unblock_Interrupt (IMNG.Interrupt_ID (Interrupt));
760 IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt));
764 --------------------------------
765 -- Unprotected_Detach_Handler --
766 --------------------------------
768 procedure Unprotected_Detach_Handler
769 (Interrupt : Interrupt_ID;
772 Old_Handler : Parameterless_Handler;
775 if User_Entry (Interrupt).T /= Null_Task then
777 -- In case we have an Interrupt Entry installed.
778 -- raise a program error. (propagate it to the caller).
780 raise Program_Error with
781 "An interrupt entry is already installed";
784 -- Note : Static = True will pass the following check. That is the
785 -- case when we want to detach a handler regardless of the static
786 -- status of the current_Handler.
788 if not Static and then User_Handler (Interrupt).Static then
790 -- Tries to detach a static Interrupt Handler.
791 -- raise a program error.
793 raise Program_Error with
794 "Trying to detach a static Interrupt Handler";
797 -- The interrupt should no longer be ignored if
798 -- it was ever ignored.
800 Ignored (Interrupt) := False;
802 Old_Handler := User_Handler (Interrupt).H;
806 User_Handler (Interrupt).H := null;
807 User_Handler (Interrupt).Static := False;
809 if Old_Handler /= null then
810 Unbind_Handler (Interrupt);
812 end Unprotected_Detach_Handler;
814 ----------------------------------
815 -- Unprotected_Exchange_Handler --
816 ----------------------------------
818 procedure Unprotected_Exchange_Handler
819 (Old_Handler : out Parameterless_Handler;
820 New_Handler : Parameterless_Handler;
821 Interrupt : Interrupt_ID;
823 Restoration : Boolean := False)
826 if User_Entry (Interrupt).T /= Null_Task then
828 -- In case we have an Interrupt Entry already installed.
829 -- raise a program error. (propagate it to the caller).
831 raise Program_Error with
832 "An interrupt is already installed";
835 -- Note : A null handler with Static = True will pass the
836 -- following check. That is the case when we want to Detach a
837 -- handler regardless of the Static status of the current_Handler.
839 -- We don't check anything if Restoration is True, since we
840 -- may be detaching a static handler to restore a dynamic one.
842 if not Restoration and then not Static
844 -- Tries to overwrite a static Interrupt Handler with a
847 and then (User_Handler (Interrupt).Static
849 -- The new handler is not specified as an
850 -- Interrupt Handler by a pragma.
852 or else not Is_Registered (New_Handler))
854 raise Program_Error with
855 "Trying to overwrite a static Interrupt Handler with a " &
859 -- The interrupt should no longer be ingnored if
860 -- it was ever ignored.
862 Ignored (Interrupt) := False;
864 -- Save the old handler
866 Old_Handler := User_Handler (Interrupt).H;
870 User_Handler (Interrupt).H := New_Handler;
872 if New_Handler = null then
874 -- The null handler means we are detaching the handler
876 User_Handler (Interrupt).Static := False;
879 User_Handler (Interrupt).Static := Static;
882 -- Invoke a corresponding Server_Task if not yet created.
883 -- Place Task_Id info in Server_ID array.
885 if Server_ID (Interrupt) = Null_Task then
887 -- When a new Server_Task is created, it should have its
888 -- signal mask set to the All_Tasks_Mask.
890 IMOP.Set_Interrupt_Mask
891 (IMOP.All_Tasks_Mask'Access, Old_Mask'Access);
892 Access_Hold := new Server_Task (Interrupt);
893 IMOP.Set_Interrupt_Mask (Old_Mask'Access);
895 Server_ID (Interrupt) := To_System (Access_Hold.all'Identity);
898 if New_Handler = null then
899 if Old_Handler /= null then
900 Unbind_Handler (Interrupt);
906 if Old_Handler = null then
907 Bind_Handler (Interrupt);
909 end Unprotected_Exchange_Handler;
911 -- Start of processing for Interrupt_Manager
914 -- By making this task independent of master, when the process
915 -- goes away, the Interrupt_Manager will terminate gracefully.
917 System.Tasking.Utilities.Make_Independent;
919 -- Environment task gets its own interrupt mask, saves it,
920 -- and then masks all interrupts except the Keep_Unmasked set.
922 -- During rendezvous, the Interrupt_Manager receives the old
923 -- interrupt mask of the environment task, and sets its own
924 -- interrupt mask to that value.
926 -- The environment task will call the entry of Interrupt_Manager some
927 -- during elaboration of the body of this package.
929 accept Initialize (Mask : IMNG.Interrupt_Mask) do
931 The_Mask : aliased IMNG.Interrupt_Mask;
934 IMOP.Copy_Interrupt_Mask (The_Mask, Mask);
935 IMOP.Set_Interrupt_Mask (The_Mask'Access);
939 -- Note: All tasks in RTS will have all the Reserve Interrupts
940 -- being masked (except the Interrupt_Manager) and Keep_Unmasked
941 -- unmasked when created.
943 -- Abort_Task_Interrupt is one of the Interrupt unmasked
944 -- in all tasks. We mask the Interrupt in this particular task
945 -- so that "sigwait" is possible to catch an explicitely sent
946 -- Abort_Task_Interrupt from the Server_Tasks.
948 -- This sigwaiting is needed so that we make sure a Server_Task is
949 -- out of its own sigwait state. This extra synchronization is
950 -- necessary to prevent following senarios.
952 -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to the
953 -- Server_Task then changes its own interrupt mask (OS level).
954 -- If an interrupt (corresponding to the Server_Task) arrives
955 -- in the nean time we have the Interrupt_Manager umnasked and
956 -- the Server_Task waiting on sigwait.
958 -- 2) For unbinding handler, we install a default action in the
959 -- Interrupt_Manager. POSIX.1c states that the result of using
960 -- "sigwait" and "sigaction" simaltaneously on the same interrupt
961 -- is undefined. Therefore, we need to be informed from the
962 -- Server_Task of the fact that the Server_Task is out of its
965 IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access);
966 IMOP.Add_To_Interrupt_Mask
967 (Intwait_Mask'Access, IMNG.Abort_Task_Interrupt);
968 IMOP.Thread_Block_Interrupt
969 (IMNG.Abort_Task_Interrupt);
972 -- A block is needed to absorb Program_Error exception
976 accept Attach_Handler
977 (New_Handler : Parameterless_Handler;
978 Interrupt : Interrupt_ID;
980 Restoration : Boolean := False)
982 Unprotected_Exchange_Handler
983 (Old_Handler, New_Handler, Interrupt, Static, Restoration);
987 accept Exchange_Handler
988 (Old_Handler : out Parameterless_Handler;
989 New_Handler : Parameterless_Handler;
990 Interrupt : Interrupt_ID;
993 Unprotected_Exchange_Handler
994 (Old_Handler, New_Handler, Interrupt, Static);
995 end Exchange_Handler;
998 accept Detach_Handler
999 (Interrupt : Interrupt_ID;
1002 Unprotected_Detach_Handler (Interrupt, Static);
1006 accept Bind_Interrupt_To_Entry
1008 E : Task_Entry_Index;
1009 Interrupt : Interrupt_ID)
1011 -- if there is a binding already (either a procedure or an
1012 -- entry), raise Program_Error (propagate it to the caller).
1014 if User_Handler (Interrupt).H /= null
1015 or else User_Entry (Interrupt).T /= Null_Task
1017 raise Program_Error with
1018 "A binding for this interrupt is already present";
1021 -- The interrupt should no longer be ingnored if
1022 -- it was ever ignored.
1024 Ignored (Interrupt) := False;
1025 User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E);
1027 -- Indicate the attachment of Interrupt Entry in ATCB.
1028 -- This is need so that when an Interrupt Entry task
1029 -- terminates the binding can be cleaned. The call to
1030 -- unbinding must be made by the task before it terminates.
1032 T.Interrupt_Entry := True;
1034 -- Invoke a corresponding Server_Task if not yet created.
1035 -- Place Task_Id info in Server_ID array.
1037 if Server_ID (Interrupt) = Null_Task then
1039 -- When a new Server_Task is created, it should have its
1040 -- signal mask set to the All_Tasks_Mask.
1042 IMOP.Set_Interrupt_Mask
1043 (IMOP.All_Tasks_Mask'Access, Old_Mask'Access);
1044 Access_Hold := new Server_Task (Interrupt);
1045 IMOP.Set_Interrupt_Mask (Old_Mask'Access);
1046 Server_ID (Interrupt) :=
1047 To_System (Access_Hold.all'Identity);
1050 Bind_Handler (Interrupt);
1051 end Bind_Interrupt_To_Entry;
1054 accept Detach_Interrupt_Entries (T : Task_Id) do
1055 for J in Interrupt_ID'Range loop
1056 if not Is_Reserved (J) then
1057 if User_Entry (J).T = T then
1059 -- The interrupt should no longer be ingnored if
1060 -- it was ever ignored.
1062 Ignored (J) := False;
1063 User_Entry (J) := Entry_Assoc'
1064 (T => Null_Task, E => Null_Task_Entry);
1070 -- Indicate in ATCB that no Interrupt Entries are attached
1072 T.Interrupt_Entry := False;
1073 end Detach_Interrupt_Entries;
1076 accept Block_Interrupt (Interrupt : Interrupt_ID) do
1077 if Blocked (Interrupt) then
1081 Blocked (Interrupt) := True;
1082 Last_Unblocker (Interrupt) := Null_Task;
1084 -- Mask this task for the given Interrupt so that all tasks
1085 -- are masked for the Interrupt.
1087 IMOP.Thread_Block_Interrupt (IMNG.Interrupt_ID (Interrupt));
1089 if User_Handler (Interrupt).H /= null
1090 or else User_Entry (Interrupt).T /= Null_Task
1092 -- This is the case where the Server_Task is waiting
1093 -- on "sigwait." Wake it up by sending an
1094 -- Abort_Task_Interrupt so that the Server_Task
1097 POP.Abort_Task (Server_ID (Interrupt));
1099 -- Make sure corresponding Server_Task is out of its own
1102 Ret_Interrupt := Interrupt_ID
1103 (IMOP.Interrupt_Wait (Intwait_Mask'Access));
1106 Interrupt_ID (IMNG.Abort_Task_Interrupt));
1108 end Block_Interrupt;
1111 accept Unblock_Interrupt (Interrupt : Interrupt_ID) do
1112 if not Blocked (Interrupt) then
1116 Blocked (Interrupt) := False;
1117 Last_Unblocker (Interrupt) :=
1118 To_System (Unblock_Interrupt'Caller);
1120 if User_Handler (Interrupt).H = null
1121 and then User_Entry (Interrupt).T = Null_Task
1123 -- No handler is attached. Unmask the Interrupt so that
1124 -- the default action can be carried out.
1126 IMOP.Thread_Unblock_Interrupt
1127 (IMNG.Interrupt_ID (Interrupt));
1130 -- The Server_Task must be waiting on the Cond variable
1131 -- since it was being blocked and an Interrupt Hander or
1132 -- an Entry was there. Wake it up and let it change
1133 -- it place of waiting according to its new state.
1135 POP.Wakeup (Server_ID (Interrupt),
1136 Interrupt_Server_Blocked_Interrupt_Sleep);
1138 end Unblock_Interrupt;
1141 accept Ignore_Interrupt (Interrupt : Interrupt_ID) do
1142 if Ignored (Interrupt) then
1146 Ignored (Interrupt) := True;
1148 -- If there is a handler associated with the Interrupt,
1149 -- detach it first. In this way we make sure that the
1150 -- Server_Task is not on sigwait. This is legal since
1151 -- Unignore_Interrupt is to install the default action.
1153 if User_Handler (Interrupt).H /= null then
1154 Unprotected_Detach_Handler
1155 (Interrupt => Interrupt, Static => True);
1157 elsif User_Entry (Interrupt).T /= Null_Task then
1158 User_Entry (Interrupt) := Entry_Assoc'
1159 (T => Null_Task, E => Null_Task_Entry);
1160 Unbind_Handler (Interrupt);
1163 IMOP.Install_Ignore_Action (IMNG.Interrupt_ID (Interrupt));
1164 end Ignore_Interrupt;
1167 accept Unignore_Interrupt (Interrupt : Interrupt_ID) do
1168 Ignored (Interrupt) := False;
1170 -- If there is a handler associated with the Interrupt,
1171 -- detach it first. In this way we make sure that the
1172 -- Server_Task is not on sigwait. This is legal since
1173 -- Unignore_Interrupt is to install the default action.
1175 if User_Handler (Interrupt).H /= null then
1176 Unprotected_Detach_Handler
1177 (Interrupt => Interrupt, Static => True);
1179 elsif User_Entry (Interrupt).T /= Null_Task then
1180 User_Entry (Interrupt) := Entry_Assoc'
1181 (T => Null_Task, E => Null_Task_Entry);
1182 Unbind_Handler (Interrupt);
1185 IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt));
1186 end Unignore_Interrupt;
1190 -- If there is a program error we just want to propagate it to
1191 -- the caller and do not want to stop this task.
1193 when Program_Error =>
1197 pragma Assert (False);
1201 end Interrupt_Manager;
1207 task body Server_Task is
1208 Intwait_Mask : aliased IMNG.Interrupt_Mask;
1209 Ret_Interrupt : Interrupt_ID;
1210 Self_ID : constant Task_Id := Self;
1211 Tmp_Handler : Parameterless_Handler;
1213 Tmp_Entry_Index : Task_Entry_Index;
1216 -- By making this task independent of master, when the process
1217 -- goes away, the Server_Task will terminate gracefully.
1219 System.Tasking.Utilities.Make_Independent;
1221 -- Install default action in system level
1223 IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt));
1225 -- Note: All tasks in RTS will have all the Reserve Interrupts being
1226 -- masked (except the Interrupt_Manager) and Keep_Unmasked unmasked when
1229 -- Abort_Task_Interrupt is one of the Interrupt unmasked in all tasks.
1230 -- We mask the Interrupt in this particular task so that "sigwait" is
1231 -- possible to catch an explicitely sent Abort_Task_Interrupt from the
1232 -- Interrupt_Manager.
1234 -- There are two Interrupt interrupts that this task catch through
1235 -- "sigwait." One is the Interrupt this task is designated to catch
1236 -- in order to execure user handler or entry. The other one is the
1237 -- Abort_Task_Interrupt. This interrupt is being sent from the
1238 -- Interrupt_Manager to inform status changes (e.g: become Blocked,
1239 -- Handler or Entry is to be detached).
1241 -- Prepare a mask to used for sigwait
1243 IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access);
1245 IMOP.Add_To_Interrupt_Mask
1246 (Intwait_Mask'Access, IMNG.Interrupt_ID (Interrupt));
1248 IMOP.Add_To_Interrupt_Mask
1249 (Intwait_Mask'Access, IMNG.Abort_Task_Interrupt);
1251 IMOP.Thread_Block_Interrupt
1252 (IMNG.Abort_Task_Interrupt);
1254 PIO.Set_Interrupt_ID (IMNG.Interrupt_ID (Interrupt), Self_ID);
1257 System.Tasking.Initialization.Defer_Abort (Self_ID);
1263 POP.Write_Lock (Self_ID);
1265 if User_Handler (Interrupt).H = null
1266 and then User_Entry (Interrupt).T = Null_Task
1268 -- No Interrupt binding. If there is an interrupt,
1269 -- Interrupt_Manager will take default action.
1271 Self_ID.Common.State := Interrupt_Server_Blocked_Interrupt_Sleep;
1272 POP.Sleep (Self_ID, Interrupt_Server_Idle_Sleep);
1273 Self_ID.Common.State := Runnable;
1275 elsif Blocked (Interrupt) then
1277 -- Interrupt is blocked. Stay here, so we won't catch
1280 Self_ID.Common.State := Interrupt_Server_Blocked_Interrupt_Sleep;
1281 POP.Sleep (Self_ID, Interrupt_Server_Blocked_Interrupt_Sleep);
1282 Self_ID.Common.State := Runnable;
1285 -- A Handler or an Entry is installed. At this point all tasks
1286 -- mask for the Interrupt is masked. Catch the Interrupt using
1289 -- This task may wake up from sigwait by receiving an interrupt
1290 -- (Abort_Task_Interrupt) from the Interrupt_Manager for unbinding
1291 -- a Procedure Handler or an Entry. Or it could be a wake up
1292 -- from status change (Unblocked -> Blocked). If that is not
1293 -- the case, we should exceute the attached Procedure or Entry.
1295 Self_ID.Common.State := Interrupt_Server_Blocked_On_Event_Flag;
1296 POP.Unlock (Self_ID);
1302 -- Avoid race condition when terminating application and
1303 -- System.Parameters.No_Abort is True.
1305 if Parameters.No_Abort and then Self_ID.Pending_Action then
1306 Initialization.Do_Pending_Action (Self_ID);
1310 Interrupt_ID (IMOP.Interrupt_Wait (Intwait_Mask'Access));
1311 Self_ID.Common.State := Runnable;
1313 if Ret_Interrupt = Interrupt_ID (IMNG.Abort_Task_Interrupt) then
1315 -- Inform the Interrupt_Manager of wakeup from above sigwait
1317 POP.Abort_Task (Interrupt_Manager_ID);
1323 POP.Write_Lock (Self_ID);
1330 POP.Write_Lock (Self_ID);
1332 if Ret_Interrupt /= Interrupt then
1334 -- On some systems (e.g. recent linux kernels), sigwait
1335 -- may return unexpectedly (with errno set to EINTR).
1340 -- Even though we have received an Interrupt the status may
1341 -- have changed already before we got the Self_ID lock above
1342 -- Therefore we make sure a Handler or an Entry is still
1343 -- there and make appropriate call.
1345 -- If there is no calls to make we need to regenerate the
1346 -- Interrupt in order not to lose it.
1348 if User_Handler (Interrupt).H /= null then
1349 Tmp_Handler := User_Handler (Interrupt).H;
1351 -- RTS calls should not be made with self being locked
1353 POP.Unlock (Self_ID);
1365 POP.Write_Lock (Self_ID);
1367 elsif User_Entry (Interrupt).T /= Null_Task then
1368 Tmp_ID := User_Entry (Interrupt).T;
1369 Tmp_Entry_Index := User_Entry (Interrupt).E;
1371 -- RTS calls should not be made with self being locked
1377 POP.Unlock (Self_ID);
1379 System.Tasking.Rendezvous.Call_Simple
1380 (Tmp_ID, Tmp_Entry_Index, System.Null_Address);
1382 POP.Write_Lock (Self_ID);
1389 -- This is a situation that this task wakes up receiving
1390 -- an Interrupt and before it gets the lock the Interrupt
1391 -- is blocked. We do not want to lose the interrupt in
1392 -- this case so we regenerate the Interrupt to process
1395 IMOP.Interrupt_Self_Process
1396 (IMNG.Interrupt_ID (Interrupt));
1402 POP.Unlock (Self_ID);
1408 System.Tasking.Initialization.Undefer_Abort (Self_ID);
1410 if Self_ID.Pending_Action then
1411 Initialization.Do_Pending_Action (Self_ID);
1414 -- Undefer abort here to allow a window for this task to be aborted
1415 -- at the time of system shutdown. We also explicitely test for
1416 -- Pending_Action in case System.Parameters.No_Abort is True.
1421 -- Elaboration code for package System.Interrupts
1424 -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent
1426 Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity);
1428 -- During the elaboration of this package body we want the RTS
1429 -- to inherit the interrupt mask from the Environment Task.
1431 IMOP.Setup_Interrupt_Mask;
1433 -- The environment task should have gotten its mask from the enclosing
1434 -- process during the RTS start up. (See processing in s-inmaop.adb). Pass
1435 -- the Interrupt_Mask of the environment task to the Interrupt_Manager.
1437 -- Note: At this point we know that all tasks are masked for non-reserved
1438 -- signals. Only the Interrupt_Manager will have masks set up differently
1439 -- inheriting the original environment task's mask.
1441 Interrupt_Manager.Initialize (IMOP.Environment_Mask);
1442 end System.Interrupts;