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-2007, 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
;
58 -- used for Task_Id type
61 -- used for Raise_Exception
63 with System
.Task_Primitives
;
67 with System
.Interrupt_Management
;
71 -- Abort_Task_Interrupt
73 with System
.Interrupt_Management
.Operations
;
74 -- used for Thread_Block_Interrupt
75 -- Thread_Unblock_Interrupt
76 -- Install_Default_Action
77 -- Install_Ignore_Action
78 -- Copy_Interrupt_Mask
80 -- Empty_Interrupt_Mask
81 -- Fill_Interrupt_Mask
82 -- Add_To_Interrupt_Mask
83 -- Delete_From_Interrupt_Mask
85 -- Interrupt_Self_Process
91 pragma Elaborate_All
(System
.Interrupt_Management
.Operations
);
93 with System
.Task_Primitives
.Operations
;
94 -- used for Write_Lock
101 with System
.Task_Primitives
.Interrupt_Operations
;
102 -- used for Set_Interrupt_ID
104 with System
.Storage_Elements
;
105 -- used for To_Address
109 with System
.Tasking
.Utilities
;
110 -- used for Make_Independent
112 with System
.Tasking
.Rendezvous
;
113 -- used for Call_Simple
114 pragma Elaborate_All
(System
.Tasking
.Rendezvous
);
116 with System
.Tasking
.Initialization
;
117 -- used for Defer_Abort
120 with System
.Parameters
;
121 -- used for Single_Lock
123 with Ada
.Unchecked_Conversion
;
125 package body System
.Interrupts
is
131 package POP
renames System
.Task_Primitives
.Operations
;
132 package PIO
renames System
.Task_Primitives
.Interrupt_Operations
;
133 package IMNG
renames System
.Interrupt_Management
;
134 package IMOP
renames System
.Interrupt_Management
.Operations
;
136 function To_System
is new Ada
.Unchecked_Conversion
137 (Ada
.Task_Identification
.Task_Id
, Task_Id
);
143 -- WARNING: System.Tasking.Stages performs calls to this task with
144 -- low-level constructs. Do not change this spec without synchronizing it.
146 task Interrupt_Manager
is
147 entry Detach_Interrupt_Entries
(T
: Task_Id
);
149 entry Initialize
(Mask
: IMNG
.Interrupt_Mask
);
152 (New_Handler
: Parameterless_Handler
;
153 Interrupt
: Interrupt_ID
;
155 Restoration
: Boolean := False);
157 entry Exchange_Handler
158 (Old_Handler
: out Parameterless_Handler
;
159 New_Handler
: Parameterless_Handler
;
160 Interrupt
: Interrupt_ID
;
164 (Interrupt
: Interrupt_ID
;
167 entry Bind_Interrupt_To_Entry
169 E
: Task_Entry_Index
;
170 Interrupt
: Interrupt_ID
);
172 entry Block_Interrupt
(Interrupt
: Interrupt_ID
);
174 entry Unblock_Interrupt
(Interrupt
: Interrupt_ID
);
176 entry Ignore_Interrupt
(Interrupt
: Interrupt_ID
);
178 entry Unignore_Interrupt
(Interrupt
: Interrupt_ID
);
180 pragma Interrupt_Priority
(System
.Interrupt_Priority
'Last);
181 end Interrupt_Manager
;
183 task type Server_Task
(Interrupt
: Interrupt_ID
) is
184 pragma Priority
(System
.Interrupt_Priority
'Last);
185 -- Note: the above pragma Priority is strictly speaking improper since
186 -- it is outside the range of allowed priorities, but the compiler
187 -- treats system units specially and does not apply this range checking
188 -- rule to system units.
192 type Server_Task_Access
is access Server_Task
;
194 -------------------------------
195 -- Local Types and Variables --
196 -------------------------------
198 type Entry_Assoc
is record
200 E
: Task_Entry_Index
;
203 type Handler_Assoc
is record
204 H
: Parameterless_Handler
;
205 Static
: Boolean; -- Indicates static binding;
208 User_Handler
: array (Interrupt_ID
'Range) of Handler_Assoc
:=
209 (others => (null, Static
=> False));
210 pragma Volatile_Components
(User_Handler
);
211 -- Holds the protected procedure handler (if any) and its Static
212 -- information for each interrupt. A handler is a Static one if it is
213 -- specified through the pragma Attach_Handler. Attach_Handler. Otherwise,
216 User_Entry
: array (Interrupt_ID
'Range) of Entry_Assoc
:=
217 (others => (T
=> Null_Task
, E
=> Null_Task_Entry
));
218 pragma Volatile_Components
(User_Entry
);
219 -- Holds the task and entry index (if any) for each interrupt
221 Blocked
: array (Interrupt_ID
'Range) of Boolean := (others => False);
222 pragma Atomic_Components
(Blocked
);
223 -- True iff the corresponding interrupt is blocked in the process level
225 Ignored
: array (Interrupt_ID
'Range) of Boolean := (others => False);
226 pragma Atomic_Components
(Ignored
);
227 -- True iff the corresponding interrupt is blocked in the process level
230 array (Interrupt_ID
'Range) of Task_Id
:= (others => Null_Task
);
231 pragma Atomic_Components
(Last_Unblocker
);
232 -- Holds the ID of the last Task which Unblocked this Interrupt. It
233 -- contains Null_Task if no tasks have ever requested the Unblocking
234 -- operation or the Interrupt is currently Blocked.
236 Server_ID
: array (Interrupt_ID
'Range) of Task_Id
:=
237 (others => Null_Task
);
238 pragma Atomic_Components
(Server_ID
);
239 -- Holds the Task_Id of the Server_Task for each interrupt. Task_Id is
240 -- needed to accomplish locking per Interrupt base. Also is needed to
241 -- decide whether to create a new Server_Task.
243 -- Type and Head, Tail of the list containing Registered Interrupt
244 -- Handlers. These definitions are used to register the handlers
245 -- specified by the pragma Interrupt_Handler.
247 type Registered_Handler
;
248 type R_Link
is access all Registered_Handler
;
250 type Registered_Handler
is record
251 H
: System
.Address
:= System
.Null_Address
;
252 Next
: R_Link
:= null;
255 Registered_Handler_Head
: R_Link
:= null;
256 Registered_Handler_Tail
: R_Link
:= null;
258 Access_Hold
: Server_Task_Access
;
259 -- Variable used to allocate Server_Task using "new"
261 -----------------------
262 -- Local Subprograms --
263 -----------------------
265 function Is_Registered
(Handler
: Parameterless_Handler
) return Boolean;
266 -- See if the Handler has been "pragma"ed using Interrupt_Handler. Always
267 -- consider a null handler as registered.
273 -- Calling this procedure with New_Handler = null and Static = True means
274 -- we want to detach the current handler regardless of the previous
275 -- handler's binding status (ie. do not care if it is a dynamic or static
278 -- This option is needed so that during the finalization of a PO, we can
279 -- detach handlers attached through pragma Attach_Handler.
281 procedure Attach_Handler
282 (New_Handler
: Parameterless_Handler
;
283 Interrupt
: Interrupt_ID
;
284 Static
: Boolean := False)
287 if Is_Reserved
(Interrupt
) then
288 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
289 Interrupt_ID
'Image (Interrupt
) & " is reserved");
292 Interrupt_Manager
.Attach_Handler
(New_Handler
, Interrupt
, Static
);
296 -----------------------------
297 -- Bind_Interrupt_To_Entry --
298 -----------------------------
300 -- This procedure raises a Program_Error if it tries to bind an interrupt
301 -- to which an Entry or a Procedure is already bound.
303 procedure Bind_Interrupt_To_Entry
305 E
: Task_Entry_Index
;
306 Int_Ref
: System
.Address
)
308 Interrupt
: constant Interrupt_ID
:=
309 Interrupt_ID
(Storage_Elements
.To_Integer
(Int_Ref
));
312 if Is_Reserved
(Interrupt
) then
313 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
314 Interrupt_ID
'Image (Interrupt
) & " is reserved");
317 Interrupt_Manager
.Bind_Interrupt_To_Entry
(T
, E
, Interrupt
);
318 end Bind_Interrupt_To_Entry
;
320 ---------------------
321 -- Block_Interrupt --
322 ---------------------
324 procedure Block_Interrupt
(Interrupt
: Interrupt_ID
) is
326 if Is_Reserved
(Interrupt
) then
327 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
328 Interrupt_ID
'Image (Interrupt
) & " is reserved");
331 Interrupt_Manager
.Block_Interrupt
(Interrupt
);
334 ---------------------
335 -- Current_Handler --
336 ---------------------
338 function Current_Handler
339 (Interrupt
: Interrupt_ID
) return Parameterless_Handler
342 if Is_Reserved
(Interrupt
) then
343 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
344 Interrupt_ID
'Image (Interrupt
) & " is reserved");
347 -- ??? Since Parameterless_Handler is not Atomic, the current
348 -- implementation is wrong. We need a new service in Interrupt_Manager
349 -- to ensure atomicity.
351 return User_Handler
(Interrupt
).H
;
358 -- Calling this procedure with Static = True means we want to Detach the
359 -- current handler regardless of the previous handler's binding status
360 -- (i.e. do not care if it is a dynamic or static handler).
362 -- This option is needed so that during the finalization of a PO, we can
363 -- detach handlers attached through pragma Attach_Handler.
365 procedure Detach_Handler
366 (Interrupt
: Interrupt_ID
;
367 Static
: Boolean := False)
370 if Is_Reserved
(Interrupt
) then
371 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
372 Interrupt_ID
'Image (Interrupt
) & " is reserved");
375 Interrupt_Manager
.Detach_Handler
(Interrupt
, Static
);
378 ------------------------------
379 -- Detach_Interrupt_Entries --
380 ------------------------------
382 procedure Detach_Interrupt_Entries
(T
: Task_Id
) is
384 Interrupt_Manager
.Detach_Interrupt_Entries
(T
);
385 end Detach_Interrupt_Entries
;
387 ----------------------
388 -- Exchange_Handler --
389 ----------------------
391 -- Calling this procedure with New_Handler = null and Static = True means
392 -- we want to detach the current handler regardless of the previous
393 -- handler's binding status (ie. do not care if it is a dynamic or static
396 -- This option is needed so that during the finalization of a PO, we can
397 -- detach handlers attached through pragma Attach_Handler.
399 procedure Exchange_Handler
400 (Old_Handler
: out Parameterless_Handler
;
401 New_Handler
: Parameterless_Handler
;
402 Interrupt
: Interrupt_ID
;
403 Static
: Boolean := False)
406 if Is_Reserved
(Interrupt
) then
407 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
408 Interrupt_ID
'Image (Interrupt
) & " is reserved");
411 Interrupt_Manager
.Exchange_Handler
412 (Old_Handler
, New_Handler
, Interrupt
, Static
);
413 end Exchange_Handler
;
419 procedure Finalize
(Object
: in out Static_Interrupt_Protection
) is
421 -- ??? loop to be executed only when we're not doing library level
422 -- finalization, since in this case all interrupt tasks are gone.
424 if not Interrupt_Manager
'Terminated then
425 for N
in reverse Object
.Previous_Handlers
'Range loop
426 Interrupt_Manager
.Attach_Handler
427 (New_Handler
=> Object
.Previous_Handlers
(N
).Handler
,
428 Interrupt
=> Object
.Previous_Handlers
(N
).Interrupt
,
429 Static
=> Object
.Previous_Handlers
(N
).Static
,
430 Restoration
=> True);
434 Tasking
.Protected_Objects
.Entries
.Finalize
435 (Tasking
.Protected_Objects
.Entries
.Protection_Entries
(Object
));
438 -------------------------------------
439 -- Has_Interrupt_Or_Attach_Handler --
440 -------------------------------------
442 -- Need comments as to why these always return True ???
444 function Has_Interrupt_Or_Attach_Handler
445 (Object
: access Dynamic_Interrupt_Protection
) return Boolean
447 pragma Unreferenced
(Object
);
450 end Has_Interrupt_Or_Attach_Handler
;
452 function Has_Interrupt_Or_Attach_Handler
453 (Object
: access Static_Interrupt_Protection
) return Boolean
455 pragma Unreferenced
(Object
);
458 end Has_Interrupt_Or_Attach_Handler
;
460 ----------------------
461 -- Ignore_Interrupt --
462 ----------------------
464 procedure Ignore_Interrupt
(Interrupt
: Interrupt_ID
) is
466 if Is_Reserved
(Interrupt
) then
467 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
468 Interrupt_ID
'Image (Interrupt
) & " is reserved");
471 Interrupt_Manager
.Ignore_Interrupt
(Interrupt
);
472 end Ignore_Interrupt
;
474 ----------------------
475 -- Install_Handlers --
476 ----------------------
478 procedure Install_Handlers
479 (Object
: access Static_Interrupt_Protection
;
480 New_Handlers
: New_Handler_Array
)
483 for N
in New_Handlers
'Range loop
485 -- We need a lock around this ???
487 Object
.Previous_Handlers
(N
).Interrupt
:= New_Handlers
(N
).Interrupt
;
488 Object
.Previous_Handlers
(N
).Static
:= User_Handler
489 (New_Handlers
(N
).Interrupt
).Static
;
491 -- We call Exchange_Handler and not directly Interrupt_Manager.
492 -- Exchange_Handler so we get the Is_Reserved check.
495 (Old_Handler
=> Object
.Previous_Handlers
(N
).Handler
,
496 New_Handler
=> New_Handlers
(N
).Handler
,
497 Interrupt
=> New_Handlers
(N
).Interrupt
,
500 end Install_Handlers
;
506 function Is_Blocked
(Interrupt
: Interrupt_ID
) return Boolean is
508 if Is_Reserved
(Interrupt
) then
509 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
510 Interrupt_ID
'Image (Interrupt
) & " is reserved");
513 return Blocked
(Interrupt
);
516 -----------------------
517 -- Is_Entry_Attached --
518 -----------------------
520 function Is_Entry_Attached
(Interrupt
: Interrupt_ID
) return Boolean is
522 if Is_Reserved
(Interrupt
) then
523 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
524 Interrupt_ID
'Image (Interrupt
) & " is reserved");
527 return User_Entry
(Interrupt
).T
/= Null_Task
;
528 end Is_Entry_Attached
;
530 -------------------------
531 -- Is_Handler_Attached --
532 -------------------------
534 function Is_Handler_Attached
(Interrupt
: Interrupt_ID
) return Boolean is
536 if Is_Reserved
(Interrupt
) then
537 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
538 Interrupt_ID
'Image (Interrupt
) & " is reserved");
541 return User_Handler
(Interrupt
).H
/= null;
542 end Is_Handler_Attached
;
548 function Is_Ignored
(Interrupt
: Interrupt_ID
) return Boolean is
550 if Is_Reserved
(Interrupt
) then
551 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
552 Interrupt_ID
'Image (Interrupt
) & " is reserved");
555 return Ignored
(Interrupt
);
562 function Is_Registered
(Handler
: Parameterless_Handler
) return Boolean is
564 type Fat_Ptr
is record
565 Object_Addr
: System
.Address
;
566 Handler_Addr
: System
.Address
;
569 function To_Fat_Ptr
is new Ada
.Unchecked_Conversion
570 (Parameterless_Handler
, Fat_Ptr
);
576 if Handler
= null then
580 Fat
:= To_Fat_Ptr
(Handler
);
582 Ptr
:= Registered_Handler_Head
;
584 while Ptr
/= null loop
585 if Ptr
.H
= Fat
.Handler_Addr
then
599 function Is_Reserved
(Interrupt
: Interrupt_ID
) return Boolean is
601 return IMNG
.Reserve
(IMNG
.Interrupt_ID
(Interrupt
));
608 function Reference
(Interrupt
: Interrupt_ID
) return System
.Address
is
610 if Is_Reserved
(Interrupt
) then
611 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
612 Interrupt_ID
'Image (Interrupt
) & " is reserved");
615 return Storage_Elements
.To_Address
616 (Storage_Elements
.Integer_Address
(Interrupt
));
619 ---------------------------------
620 -- Register_Interrupt_Handler --
621 ---------------------------------
623 procedure Register_Interrupt_Handler
(Handler_Addr
: System
.Address
) is
624 New_Node_Ptr
: R_Link
;
627 -- This routine registers the Handler as usable for Dynamic Interrupt
628 -- Handler. Routines attaching and detaching Handler dynamically should
629 -- first consult if the Handler is registered. A Program Error should
630 -- be raised if it is not registered.
632 -- The pragma Interrupt_Handler can only appear in the library level PO
633 -- definition and instantiation. Therefore, we do not need to implement
634 -- Unregistering operation. Neither we need to protect the queue
635 -- structure using a Lock.
637 pragma Assert
(Handler_Addr
/= System
.Null_Address
);
639 New_Node_Ptr
:= new Registered_Handler
;
640 New_Node_Ptr
.H
:= Handler_Addr
;
642 if Registered_Handler_Head
= null then
643 Registered_Handler_Head
:= New_Node_Ptr
;
644 Registered_Handler_Tail
:= New_Node_Ptr
;
647 Registered_Handler_Tail
.Next
:= New_Node_Ptr
;
648 Registered_Handler_Tail
:= New_Node_Ptr
;
650 end Register_Interrupt_Handler
;
652 -----------------------
653 -- Unblock_Interrupt --
654 -----------------------
656 procedure Unblock_Interrupt
(Interrupt
: Interrupt_ID
) is
658 if Is_Reserved
(Interrupt
) then
659 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
660 Interrupt_ID
'Image (Interrupt
) & " is reserved");
663 Interrupt_Manager
.Unblock_Interrupt
(Interrupt
);
664 end Unblock_Interrupt
;
670 function Unblocked_By
671 (Interrupt
: Interrupt_ID
) return System
.Tasking
.Task_Id
674 if Is_Reserved
(Interrupt
) then
675 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
676 Interrupt_ID
'Image (Interrupt
) & " is reserved");
679 return Last_Unblocker
(Interrupt
);
682 ------------------------
683 -- Unignore_Interrupt --
684 ------------------------
686 procedure Unignore_Interrupt
(Interrupt
: Interrupt_ID
) is
688 if Is_Reserved
(Interrupt
) then
689 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
690 Interrupt_ID
'Image (Interrupt
) & " is reserved");
693 Interrupt_Manager
.Unignore_Interrupt
(Interrupt
);
694 end Unignore_Interrupt
;
696 -----------------------
697 -- Interrupt_Manager --
698 -----------------------
700 task body Interrupt_Manager
is
702 ---------------------
703 -- Local Variables --
704 ---------------------
706 Intwait_Mask
: aliased IMNG
.Interrupt_Mask
;
707 Ret_Interrupt
: Interrupt_ID
;
708 Old_Mask
: aliased IMNG
.Interrupt_Mask
;
709 Old_Handler
: Parameterless_Handler
;
715 procedure Bind_Handler
(Interrupt
: Interrupt_ID
);
716 -- This procedure does not do anything if the Interrupt is blocked.
717 -- Otherwise, we have to interrupt Server_Task for status change through
720 procedure Unbind_Handler
(Interrupt
: Interrupt_ID
);
721 -- This procedure does not do anything if the Interrupt is blocked.
722 -- Otherwise, we have to interrupt Server_Task for status change
723 -- through abort interrupt.
725 procedure Unprotected_Exchange_Handler
726 (Old_Handler
: out Parameterless_Handler
;
727 New_Handler
: Parameterless_Handler
;
728 Interrupt
: Interrupt_ID
;
730 Restoration
: Boolean := False);
732 procedure Unprotected_Detach_Handler
733 (Interrupt
: Interrupt_ID
;
740 procedure Bind_Handler
(Interrupt
: Interrupt_ID
) is
742 if not Blocked
(Interrupt
) then
744 -- Mask this task for the given Interrupt so that all tasks
745 -- are masked for the Interrupt and the actuall delivery of the
746 -- Interrupt will be caught using "sigwait" by the
747 -- corresponding Server_Task.
749 IMOP
.Thread_Block_Interrupt
(IMNG
.Interrupt_ID
(Interrupt
));
751 -- We have installed a Handler or an Entry before we called
752 -- this procedure. If the Handler Task is waiting to be awakened,
753 -- do it here. Otherwise, the interrupt will be discarded.
755 POP
.Wakeup
(Server_ID
(Interrupt
), Interrupt_Server_Idle_Sleep
);
763 procedure Unbind_Handler
(Interrupt
: Interrupt_ID
) is
764 Server
: System
.Tasking
.Task_Id
;
766 if not Blocked
(Interrupt
) then
767 -- Currently, there is a Handler or an Entry attached and
768 -- corresponding Server_Task is waiting on "sigwait."
769 -- We have to wake up the Server_Task and make it
770 -- wait on condition variable by sending an
771 -- Abort_Task_Interrupt
773 Server
:= Server_ID
(Interrupt
);
775 case Server
.Common
.State
is
776 when Interrupt_Server_Idle_Sleep |
777 Interrupt_Server_Blocked_Interrupt_Sleep
779 POP
.Wakeup
(Server
, Server
.Common
.State
);
781 when Interrupt_Server_Blocked_On_Event_Flag
=>
782 POP
.Abort_Task
(Server
);
784 -- Make sure corresponding Server_Task is out of its
785 -- own sigwait state.
788 Interrupt_ID
(IMOP
.Interrupt_Wait
(Intwait_Mask
'Access));
790 (Ret_Interrupt
= Interrupt_ID
(IMNG
.Abort_Task_Interrupt
));
796 pragma Assert
(False);
800 IMOP
.Install_Default_Action
(IMNG
.Interrupt_ID
(Interrupt
));
802 -- Unmake the Interrupt for this task in order to allow default
805 IMOP
.Thread_Unblock_Interrupt
(IMNG
.Interrupt_ID
(Interrupt
));
808 IMOP
.Install_Default_Action
(IMNG
.Interrupt_ID
(Interrupt
));
812 --------------------------------
813 -- Unprotected_Detach_Handler --
814 --------------------------------
816 procedure Unprotected_Detach_Handler
817 (Interrupt
: Interrupt_ID
;
820 Old_Handler
: Parameterless_Handler
;
823 if User_Entry
(Interrupt
).T
/= Null_Task
then
825 -- In case we have an Interrupt Entry installed.
826 -- raise a program error. (propagate it to the caller).
828 Raise_Exception
(Program_Error
'Identity,
829 "An interrupt entry is already installed");
832 -- Note : Static = True will pass the following check. That is the
833 -- case when we want to detach a handler regardless of the static
834 -- status of the current_Handler.
836 if not Static
and then User_Handler
(Interrupt
).Static
then
838 -- Tries to detach a static Interrupt Handler.
839 -- raise a program error.
841 Raise_Exception
(Program_Error
'Identity,
842 "Trying to detach a static Interrupt Handler");
845 -- The interrupt should no longer be ignored if
846 -- it was ever ignored.
848 Ignored
(Interrupt
) := False;
850 Old_Handler
:= User_Handler
(Interrupt
).H
;
854 User_Handler
(Interrupt
).H
:= null;
855 User_Handler
(Interrupt
).Static
:= False;
857 if Old_Handler
/= null then
858 Unbind_Handler
(Interrupt
);
860 end Unprotected_Detach_Handler
;
862 ----------------------------------
863 -- Unprotected_Exchange_Handler --
864 ----------------------------------
866 procedure Unprotected_Exchange_Handler
867 (Old_Handler
: out Parameterless_Handler
;
868 New_Handler
: Parameterless_Handler
;
869 Interrupt
: Interrupt_ID
;
871 Restoration
: Boolean := False)
874 if User_Entry
(Interrupt
).T
/= Null_Task
then
876 -- In case we have an Interrupt Entry already installed.
877 -- raise a program error. (propagate it to the caller).
879 Raise_Exception
(Program_Error
'Identity,
880 "An interrupt is already installed");
883 -- Note : A null handler with Static = True will pass the
884 -- following check. That is the case when we want to Detach a
885 -- handler regardless of the Static status of the current_Handler.
887 -- We don't check anything if Restoration is True, since we
888 -- may be detaching a static handler to restore a dynamic one.
890 if not Restoration
and then not Static
892 -- Tries to overwrite a static Interrupt Handler with a
895 and then (User_Handler
(Interrupt
).Static
897 -- The new handler is not specified as an
898 -- Interrupt Handler by a pragma.
900 or else not Is_Registered
(New_Handler
))
902 Raise_Exception
(Program_Error
'Identity,
903 "Trying to overwrite a static Interrupt Handler with a " &
907 -- The interrupt should no longer be ingnored if
908 -- it was ever ignored.
910 Ignored
(Interrupt
) := False;
912 -- Save the old handler
914 Old_Handler
:= User_Handler
(Interrupt
).H
;
918 User_Handler
(Interrupt
).H
:= New_Handler
;
920 if New_Handler
= null then
922 -- The null handler means we are detaching the handler
924 User_Handler
(Interrupt
).Static
:= False;
927 User_Handler
(Interrupt
).Static
:= Static
;
930 -- Invoke a corresponding Server_Task if not yet created.
931 -- Place Task_Id info in Server_ID array.
933 if Server_ID
(Interrupt
) = Null_Task
then
935 -- When a new Server_Task is created, it should have its
936 -- signal mask set to the All_Tasks_Mask.
938 IMOP
.Set_Interrupt_Mask
939 (IMOP
.All_Tasks_Mask
'Access, Old_Mask
'Access);
940 Access_Hold
:= new Server_Task
(Interrupt
);
941 IMOP
.Set_Interrupt_Mask
(Old_Mask
'Access);
943 Server_ID
(Interrupt
) := To_System
(Access_Hold
.all'Identity);
946 if New_Handler
= null then
947 if Old_Handler
/= null then
948 Unbind_Handler
(Interrupt
);
954 if Old_Handler
= null then
955 Bind_Handler
(Interrupt
);
957 end Unprotected_Exchange_Handler
;
959 -- Start of processing for Interrupt_Manager
962 -- By making this task independent of master, when the process
963 -- goes away, the Interrupt_Manager will terminate gracefully.
965 System
.Tasking
.Utilities
.Make_Independent
;
967 -- Environment task gets its own interrupt mask, saves it,
968 -- and then masks all interrupts except the Keep_Unmasked set.
970 -- During rendezvous, the Interrupt_Manager receives the old
971 -- interrupt mask of the environment task, and sets its own
972 -- interrupt mask to that value.
974 -- The environment task will call the entry of Interrupt_Manager some
975 -- during elaboration of the body of this package.
977 accept Initialize
(Mask
: IMNG
.Interrupt_Mask
) do
979 The_Mask
: aliased IMNG
.Interrupt_Mask
;
982 IMOP
.Copy_Interrupt_Mask
(The_Mask
, Mask
);
983 IMOP
.Set_Interrupt_Mask
(The_Mask
'Access);
987 -- Note: All tasks in RTS will have all the Reserve Interrupts
988 -- being masked (except the Interrupt_Manager) and Keep_Unmasked
989 -- unmasked when created.
991 -- Abort_Task_Interrupt is one of the Interrupt unmasked
992 -- in all tasks. We mask the Interrupt in this particular task
993 -- so that "sigwait" is possible to catch an explicitely sent
994 -- Abort_Task_Interrupt from the Server_Tasks.
996 -- This sigwaiting is needed so that we make sure a Server_Task is
997 -- out of its own sigwait state. This extra synchronization is
998 -- necessary to prevent following senarios.
1000 -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to the
1001 -- Server_Task then changes its own interrupt mask (OS level).
1002 -- If an interrupt (corresponding to the Server_Task) arrives
1003 -- in the nean time we have the Interrupt_Manager umnasked and
1004 -- the Server_Task waiting on sigwait.
1006 -- 2) For unbinding handler, we install a default action in the
1007 -- Interrupt_Manager. POSIX.1c states that the result of using
1008 -- "sigwait" and "sigaction" simaltaneously on the same interrupt
1009 -- is undefined. Therefore, we need to be informed from the
1010 -- Server_Task of the fact that the Server_Task is out of its
1013 IMOP
.Empty_Interrupt_Mask
(Intwait_Mask
'Access);
1014 IMOP
.Add_To_Interrupt_Mask
1015 (Intwait_Mask
'Access, IMNG
.Abort_Task_Interrupt
);
1016 IMOP
.Thread_Block_Interrupt
1017 (IMNG
.Abort_Task_Interrupt
);
1020 -- A block is needed to absorb Program_Error exception
1024 accept Attach_Handler
1025 (New_Handler
: Parameterless_Handler
;
1026 Interrupt
: Interrupt_ID
;
1028 Restoration
: Boolean := False)
1030 Unprotected_Exchange_Handler
1031 (Old_Handler
, New_Handler
, Interrupt
, Static
, Restoration
);
1035 accept Exchange_Handler
1036 (Old_Handler
: out Parameterless_Handler
;
1037 New_Handler
: Parameterless_Handler
;
1038 Interrupt
: Interrupt_ID
;
1041 Unprotected_Exchange_Handler
1042 (Old_Handler
, New_Handler
, Interrupt
, Static
);
1043 end Exchange_Handler
;
1046 accept Detach_Handler
1047 (Interrupt
: Interrupt_ID
;
1050 Unprotected_Detach_Handler
(Interrupt
, Static
);
1054 accept Bind_Interrupt_To_Entry
1056 E
: Task_Entry_Index
;
1057 Interrupt
: Interrupt_ID
)
1059 -- if there is a binding already (either a procedure or an
1060 -- entry), raise Program_Error (propagate it to the caller).
1062 if User_Handler
(Interrupt
).H
/= null
1063 or else User_Entry
(Interrupt
).T
/= Null_Task
1065 Raise_Exception
(Program_Error
'Identity,
1066 "A binding for this interrupt is already present");
1069 -- The interrupt should no longer be ingnored if
1070 -- it was ever ignored.
1072 Ignored
(Interrupt
) := False;
1073 User_Entry
(Interrupt
) := Entry_Assoc
'(T => T, E => E);
1075 -- Indicate the attachment of Interrupt Entry in ATCB.
1076 -- This is need so that when an Interrupt Entry task
1077 -- terminates the binding can be cleaned. The call to
1078 -- unbinding must be made by the task before it terminates.
1080 T.Interrupt_Entry := True;
1082 -- Invoke a corresponding Server_Task if not yet created.
1083 -- Place Task_Id info in Server_ID array.
1085 if Server_ID (Interrupt) = Null_Task then
1087 -- When a new Server_Task is created, it should have its
1088 -- signal mask set to the All_Tasks_Mask.
1090 IMOP.Set_Interrupt_Mask
1091 (IMOP.All_Tasks_Mask'Access, Old_Mask'Access);
1092 Access_Hold := new Server_Task (Interrupt);
1093 IMOP.Set_Interrupt_Mask (Old_Mask'Access);
1094 Server_ID (Interrupt) :=
1095 To_System (Access_Hold.all'Identity);
1098 Bind_Handler (Interrupt);
1099 end Bind_Interrupt_To_Entry;
1102 accept Detach_Interrupt_Entries (T : Task_Id) do
1103 for J in Interrupt_ID'Range loop
1104 if not Is_Reserved (J) then
1105 if User_Entry (J).T = T then
1107 -- The interrupt should no longer be ingnored if
1108 -- it was ever ignored.
1110 Ignored (J) := False;
1111 User_Entry (J) := Entry_Assoc'
1112 (T
=> Null_Task
, E
=> Null_Task_Entry
);
1118 -- Indicate in ATCB that no Interrupt Entries are attached
1120 T
.Interrupt_Entry
:= False;
1121 end Detach_Interrupt_Entries
;
1124 accept Block_Interrupt
(Interrupt
: Interrupt_ID
) do
1125 if Blocked
(Interrupt
) then
1129 Blocked
(Interrupt
) := True;
1130 Last_Unblocker
(Interrupt
) := Null_Task
;
1132 -- Mask this task for the given Interrupt so that all tasks
1133 -- are masked for the Interrupt.
1135 IMOP
.Thread_Block_Interrupt
(IMNG
.Interrupt_ID
(Interrupt
));
1137 if User_Handler
(Interrupt
).H
/= null
1138 or else User_Entry
(Interrupt
).T
/= Null_Task
1140 -- This is the case where the Server_Task is waiting
1141 -- on "sigwait." Wake it up by sending an
1142 -- Abort_Task_Interrupt so that the Server_Task
1145 POP
.Abort_Task
(Server_ID
(Interrupt
));
1147 -- Make sure corresponding Server_Task is out of its own
1150 Ret_Interrupt
:= Interrupt_ID
1151 (IMOP
.Interrupt_Wait
(Intwait_Mask
'Access));
1154 Interrupt_ID
(IMNG
.Abort_Task_Interrupt
));
1156 end Block_Interrupt
;
1159 accept Unblock_Interrupt
(Interrupt
: Interrupt_ID
) do
1160 if not Blocked
(Interrupt
) then
1164 Blocked
(Interrupt
) := False;
1165 Last_Unblocker
(Interrupt
) :=
1166 To_System
(Unblock_Interrupt
'Caller);
1168 if User_Handler
(Interrupt
).H
= null
1169 and then User_Entry
(Interrupt
).T
= Null_Task
1171 -- No handler is attached. Unmask the Interrupt so that
1172 -- the default action can be carried out.
1174 IMOP
.Thread_Unblock_Interrupt
1175 (IMNG
.Interrupt_ID
(Interrupt
));
1178 -- The Server_Task must be waiting on the Cond variable
1179 -- since it was being blocked and an Interrupt Hander or
1180 -- an Entry was there. Wake it up and let it change
1181 -- it place of waiting according to its new state.
1183 POP
.Wakeup
(Server_ID
(Interrupt
),
1184 Interrupt_Server_Blocked_Interrupt_Sleep
);
1186 end Unblock_Interrupt
;
1189 accept Ignore_Interrupt
(Interrupt
: Interrupt_ID
) do
1190 if Ignored
(Interrupt
) then
1194 Ignored
(Interrupt
) := True;
1196 -- If there is a handler associated with the Interrupt,
1197 -- detach it first. In this way we make sure that the
1198 -- Server_Task is not on sigwait. This is legal since
1199 -- Unignore_Interrupt is to install the default action.
1201 if User_Handler
(Interrupt
).H
/= null then
1202 Unprotected_Detach_Handler
1203 (Interrupt
=> Interrupt
, Static
=> True);
1205 elsif User_Entry
(Interrupt
).T
/= Null_Task
then
1206 User_Entry
(Interrupt
) := Entry_Assoc
'
1207 (T => Null_Task, E => Null_Task_Entry);
1208 Unbind_Handler (Interrupt);
1211 IMOP.Install_Ignore_Action (IMNG.Interrupt_ID (Interrupt));
1212 end Ignore_Interrupt;
1215 accept Unignore_Interrupt (Interrupt : Interrupt_ID) do
1216 Ignored (Interrupt) := False;
1218 -- If there is a handler associated with the Interrupt,
1219 -- detach it first. In this way we make sure that the
1220 -- Server_Task is not on sigwait. This is legal since
1221 -- Unignore_Interrupt is to install the default action.
1223 if User_Handler (Interrupt).H /= null then
1224 Unprotected_Detach_Handler
1225 (Interrupt => Interrupt, Static => True);
1227 elsif User_Entry (Interrupt).T /= Null_Task then
1228 User_Entry (Interrupt) := Entry_Assoc'
1229 (T
=> Null_Task
, E
=> Null_Task_Entry
);
1230 Unbind_Handler
(Interrupt
);
1233 IMOP
.Install_Default_Action
(IMNG
.Interrupt_ID
(Interrupt
));
1234 end Unignore_Interrupt
;
1238 -- If there is a program error we just want to propagate it to
1239 -- the caller and do not want to stop this task.
1241 when Program_Error
=>
1245 pragma Assert
(False);
1249 end Interrupt_Manager
;
1255 task body Server_Task
is
1256 Intwait_Mask
: aliased IMNG
.Interrupt_Mask
;
1257 Ret_Interrupt
: Interrupt_ID
;
1258 Self_ID
: constant Task_Id
:= Self
;
1259 Tmp_Handler
: Parameterless_Handler
;
1261 Tmp_Entry_Index
: Task_Entry_Index
;
1264 -- By making this task independent of master, when the process
1265 -- goes away, the Server_Task will terminate gracefully.
1267 System
.Tasking
.Utilities
.Make_Independent
;
1269 -- Install default action in system level
1271 IMOP
.Install_Default_Action
(IMNG
.Interrupt_ID
(Interrupt
));
1273 -- Note: All tasks in RTS will have all the Reserve Interrupts being
1274 -- masked (except the Interrupt_Manager) and Keep_Unmasked unmasked when
1277 -- Abort_Task_Interrupt is one of the Interrupt unmasked in all tasks.
1278 -- We mask the Interrupt in this particular task so that "sigwait" is
1279 -- possible to catch an explicitely sent Abort_Task_Interrupt from the
1280 -- Interrupt_Manager.
1282 -- There are two Interrupt interrupts that this task catch through
1283 -- "sigwait." One is the Interrupt this task is designated to catch
1284 -- in order to execure user handler or entry. The other one is the
1285 -- Abort_Task_Interrupt. This interrupt is being sent from the
1286 -- Interrupt_Manager to inform status changes (e.g: become Blocked,
1287 -- Handler or Entry is to be detached).
1289 -- Prepare a mask to used for sigwait
1291 IMOP
.Empty_Interrupt_Mask
(Intwait_Mask
'Access);
1293 IMOP
.Add_To_Interrupt_Mask
1294 (Intwait_Mask
'Access, IMNG
.Interrupt_ID
(Interrupt
));
1296 IMOP
.Add_To_Interrupt_Mask
1297 (Intwait_Mask
'Access, IMNG
.Abort_Task_Interrupt
);
1299 IMOP
.Thread_Block_Interrupt
1300 (IMNG
.Abort_Task_Interrupt
);
1302 PIO
.Set_Interrupt_ID
(IMNG
.Interrupt_ID
(Interrupt
), Self_ID
);
1305 System
.Tasking
.Initialization
.Defer_Abort
(Self_ID
);
1311 POP
.Write_Lock
(Self_ID
);
1313 if User_Handler
(Interrupt
).H
= null
1314 and then User_Entry
(Interrupt
).T
= Null_Task
1316 -- No Interrupt binding. If there is an interrupt,
1317 -- Interrupt_Manager will take default action.
1319 Self_ID
.Common
.State
:= Interrupt_Server_Blocked_Interrupt_Sleep
;
1320 POP
.Sleep
(Self_ID
, Interrupt_Server_Idle_Sleep
);
1321 Self_ID
.Common
.State
:= Runnable
;
1323 elsif Blocked
(Interrupt
) then
1325 -- Interrupt is blocked. Stay here, so we won't catch
1328 Self_ID
.Common
.State
:= Interrupt_Server_Blocked_Interrupt_Sleep
;
1329 POP
.Sleep
(Self_ID
, Interrupt_Server_Blocked_Interrupt_Sleep
);
1330 Self_ID
.Common
.State
:= Runnable
;
1333 -- A Handler or an Entry is installed. At this point all tasks
1334 -- mask for the Interrupt is masked. Catch the Interrupt using
1337 -- This task may wake up from sigwait by receiving an interrupt
1338 -- (Abort_Task_Interrupt) from the Interrupt_Manager for unbinding
1339 -- a Procedure Handler or an Entry. Or it could be a wake up
1340 -- from status change (Unblocked -> Blocked). If that is not
1341 -- the case, we should exceute the attached Procedure or Entry.
1343 Self_ID
.Common
.State
:= Interrupt_Server_Blocked_On_Event_Flag
;
1344 POP
.Unlock
(Self_ID
);
1350 -- Avoid race condition when terminating application and
1351 -- System.Parameters.No_Abort is True.
1353 if Parameters
.No_Abort
and then Self_ID
.Pending_Action
then
1354 Initialization
.Do_Pending_Action
(Self_ID
);
1358 Interrupt_ID
(IMOP
.Interrupt_Wait
(Intwait_Mask
'Access));
1359 Self_ID
.Common
.State
:= Runnable
;
1361 if Ret_Interrupt
= Interrupt_ID
(IMNG
.Abort_Task_Interrupt
) then
1363 -- Inform the Interrupt_Manager of wakeup from above sigwait
1365 POP
.Abort_Task
(Interrupt_Manager_ID
);
1371 POP
.Write_Lock
(Self_ID
);
1378 POP
.Write_Lock
(Self_ID
);
1380 if Ret_Interrupt
/= Interrupt
then
1382 -- On some systems (e.g. recent linux kernels), sigwait
1383 -- may return unexpectedly (with errno set to EINTR).
1388 -- Even though we have received an Interrupt the status may
1389 -- have changed already before we got the Self_ID lock above
1390 -- Therefore we make sure a Handler or an Entry is still
1391 -- there and make appropriate call.
1393 -- If there is no calls to make we need to regenerate the
1394 -- Interrupt in order not to lose it.
1396 if User_Handler
(Interrupt
).H
/= null then
1397 Tmp_Handler
:= User_Handler
(Interrupt
).H
;
1399 -- RTS calls should not be made with self being locked
1401 POP
.Unlock
(Self_ID
);
1413 POP
.Write_Lock
(Self_ID
);
1415 elsif User_Entry
(Interrupt
).T
/= Null_Task
then
1416 Tmp_ID
:= User_Entry
(Interrupt
).T
;
1417 Tmp_Entry_Index
:= User_Entry
(Interrupt
).E
;
1419 -- RTS calls should not be made with self being locked
1425 POP
.Unlock
(Self_ID
);
1427 System
.Tasking
.Rendezvous
.Call_Simple
1428 (Tmp_ID
, Tmp_Entry_Index
, System
.Null_Address
);
1430 POP
.Write_Lock
(Self_ID
);
1437 -- This is a situation that this task wakes up receiving
1438 -- an Interrupt and before it gets the lock the Interrupt
1439 -- is blocked. We do not want to lose the interrupt in
1440 -- this case so we regenerate the Interrupt to process
1443 IMOP
.Interrupt_Self_Process
1444 (IMNG
.Interrupt_ID
(Interrupt
));
1450 POP
.Unlock
(Self_ID
);
1456 System
.Tasking
.Initialization
.Undefer_Abort
(Self_ID
);
1458 if Self_ID
.Pending_Action
then
1459 Initialization
.Do_Pending_Action
(Self_ID
);
1462 -- Undefer abort here to allow a window for this task to be aborted
1463 -- at the time of system shutdown. We also explicitely test for
1464 -- Pending_Action in case System.Parameters.No_Abort is True.
1469 -- Elaboration code for package System.Interrupts
1472 -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent
1474 Interrupt_Manager_ID
:= To_System
(Interrupt_Manager
'Identity);
1476 -- During the elaboration of this package body we want the RTS
1477 -- to inherit the interrupt mask from the Environment Task.
1479 IMOP
.Setup_Interrupt_Mask
;
1481 -- The environment task should have gotten its mask from the enclosing
1482 -- process during the RTS start up. (See processing in s-inmaop.adb). Pass
1483 -- the Interrupt_Mask of the environment task to the Interrupt_Manager.
1485 -- Note: At this point we know that all tasks are masked for non-reserved
1486 -- signals. Only the Interrupt_Manager will have masks set up differently
1487 -- inheriting the original environment task's mask.
1489 Interrupt_Manager
.Initialize
(IMOP
.Environment_Mask
);
1490 end System
.Interrupts
;