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-2006, 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 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 Unchecked_Conversion
137 (Ada
.Task_Identification
.Task_Id
, Task_Id
);
143 -- WARNING: System.Tasking.Stages performs calls to this task
144 -- with low-level constructs. Do not change this spec without synchro-
147 task Interrupt_Manager
is
148 entry Detach_Interrupt_Entries
(T
: Task_Id
);
150 entry Initialize
(Mask
: IMNG
.Interrupt_Mask
);
153 (New_Handler
: Parameterless_Handler
;
154 Interrupt
: Interrupt_ID
;
156 Restoration
: Boolean := False);
158 entry Exchange_Handler
159 (Old_Handler
: out Parameterless_Handler
;
160 New_Handler
: Parameterless_Handler
;
161 Interrupt
: Interrupt_ID
;
165 (Interrupt
: Interrupt_ID
;
168 entry Bind_Interrupt_To_Entry
170 E
: Task_Entry_Index
;
171 Interrupt
: Interrupt_ID
);
173 entry Block_Interrupt
(Interrupt
: Interrupt_ID
);
175 entry Unblock_Interrupt
(Interrupt
: Interrupt_ID
);
177 entry Ignore_Interrupt
(Interrupt
: Interrupt_ID
);
179 entry Unignore_Interrupt
(Interrupt
: Interrupt_ID
);
181 pragma Interrupt_Priority
(System
.Interrupt_Priority
'Last);
182 end Interrupt_Manager
;
184 task type Server_Task
(Interrupt
: Interrupt_ID
) is
185 pragma Priority
(System
.Interrupt_Priority
'Last);
186 -- Note: the above pragma Priority is strictly speaking improper
187 -- since it is outside the range of allowed priorities, but the
188 -- compiler treats system units specially and does not apply
189 -- this range checking rule to system units.
193 type Server_Task_Access
is access Server_Task
;
195 -------------------------------
196 -- Local Types and Variables --
197 -------------------------------
199 type Entry_Assoc
is record
201 E
: Task_Entry_Index
;
204 type Handler_Assoc
is record
205 H
: Parameterless_Handler
;
206 Static
: Boolean; -- Indicates static binding;
209 User_Handler
: array (Interrupt_ID
'Range) of Handler_Assoc
:=
210 (others => (null, Static
=> False));
211 pragma Volatile_Components
(User_Handler
);
212 -- Holds the protected procedure handler (if any) and its Static
213 -- information for each interrupt. A handler is a Static one if
214 -- it is specified through the pragma Attach_Handler.
215 -- Attach_Handler. Otherwise, not static)
217 User_Entry
: array (Interrupt_ID
'Range) of Entry_Assoc
:=
218 (others => (T
=> Null_Task
, E
=> Null_Task_Entry
));
219 pragma Volatile_Components
(User_Entry
);
220 -- Holds the task and entry index (if any) for each interrupt
222 Blocked
: array (Interrupt_ID
'Range) of Boolean := (others => False);
223 pragma Volatile_Components
(Blocked
);
224 -- True iff the corresponding interrupt is blocked in the process level
226 Ignored
: array (Interrupt_ID
'Range) of Boolean := (others => False);
227 pragma Volatile_Components
(Ignored
);
228 -- True iff the corresponding interrupt is blocked in the process level
231 array (Interrupt_ID
'Range) of Task_Id
:= (others => Null_Task
);
232 pragma Volatile_Components
(Last_Unblocker
);
233 -- Holds the ID of the last Task which Unblocked this Interrupt.
234 -- It contains Null_Task if no tasks have ever requested the
235 -- Unblocking operation or the Interrupt is currently Blocked.
237 Server_ID
: array (Interrupt_ID
'Range) of Task_Id
:=
238 (others => Null_Task
);
239 pragma Atomic_Components
(Server_ID
);
240 -- Holds the Task_Id of the Server_Task for each interrupt.
241 -- Task_Id is needed to accomplish locking per Interrupt base. Also
242 -- is needed to decide whether to create a new Server_Task.
244 -- Type and Head, Tail of the list containing Registered Interrupt
245 -- Handlers. These definitions are used to register the handlers
246 -- specified by the pragma Interrupt_Handler.
248 type Registered_Handler
;
249 type R_Link
is access all Registered_Handler
;
251 type Registered_Handler
is record
252 H
: System
.Address
:= System
.Null_Address
;
253 Next
: R_Link
:= null;
256 Registered_Handler_Head
: R_Link
:= null;
257 Registered_Handler_Tail
: R_Link
:= null;
259 Access_Hold
: Server_Task_Access
;
260 -- variable used to allocate Server_Task using "new".
262 -----------------------
263 -- Local Subprograms --
264 -----------------------
266 function Is_Registered
(Handler
: Parameterless_Handler
) return Boolean;
267 -- See if the Handler has been "pragma"ed using Interrupt_Handler.
268 -- Always consider a null handler as registered.
274 -- Calling this procedure with New_Handler = null and Static = True
275 -- means we want to detach the current handler regardless of the
276 -- previous handler's binding status (ie. do not care if it is a
277 -- dynamic or static handler).
279 -- This option is needed so that during the finalization of a PO, we
280 -- can detach handlers attached through pragma Attach_Handler.
282 procedure Attach_Handler
283 (New_Handler
: Parameterless_Handler
;
284 Interrupt
: Interrupt_ID
;
285 Static
: Boolean := False)
288 if Is_Reserved
(Interrupt
) then
289 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
290 Interrupt_ID
'Image (Interrupt
) & " is reserved");
293 Interrupt_Manager
.Attach_Handler
(New_Handler
, Interrupt
, Static
);
297 -----------------------------
298 -- Bind_Interrupt_To_Entry --
299 -----------------------------
301 -- This procedure raises a Program_Error if it tries to bind an
302 -- interrupt to which an Entry or a Procedure is already bound.
304 procedure Bind_Interrupt_To_Entry
306 E
: Task_Entry_Index
;
307 Int_Ref
: System
.Address
)
309 Interrupt
: constant Interrupt_ID
:=
310 Interrupt_ID
(Storage_Elements
.To_Integer
(Int_Ref
));
313 if Is_Reserved
(Interrupt
) then
314 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
315 Interrupt_ID
'Image (Interrupt
) & " is reserved");
318 Interrupt_Manager
.Bind_Interrupt_To_Entry
(T
, E
, Interrupt
);
319 end Bind_Interrupt_To_Entry
;
321 ---------------------
322 -- Block_Interrupt --
323 ---------------------
325 procedure Block_Interrupt
(Interrupt
: Interrupt_ID
) is
327 if Is_Reserved
(Interrupt
) then
328 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
329 Interrupt_ID
'Image (Interrupt
) & " is reserved");
332 Interrupt_Manager
.Block_Interrupt
(Interrupt
);
335 ---------------------
336 -- Current_Handler --
337 ---------------------
339 function Current_Handler
340 (Interrupt
: Interrupt_ID
) return Parameterless_Handler
343 if Is_Reserved
(Interrupt
) then
344 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
345 Interrupt_ID
'Image (Interrupt
) & " is reserved");
348 -- ??? Since Parameterless_Handler is not Atomic, the current
349 -- implementation is wrong. We need a new service in Interrupt_Manager
350 -- to ensure atomicity.
352 return User_Handler
(Interrupt
).H
;
359 -- Calling this procedure with Static = True means we want to Detach the
360 -- current handler regardless of the previous handler's binding status
361 -- (i.e. do not care if it is a dynamic or static handler).
363 -- This option is needed so that during the finalization of a PO, we can
364 -- detach handlers attached through pragma Attach_Handler.
366 procedure Detach_Handler
367 (Interrupt
: Interrupt_ID
;
368 Static
: Boolean := False)
371 if Is_Reserved
(Interrupt
) then
372 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
373 Interrupt_ID
'Image (Interrupt
) & " is reserved");
376 Interrupt_Manager
.Detach_Handler
(Interrupt
, Static
);
379 ------------------------------
380 -- Detach_Interrupt_Entries --
381 ------------------------------
383 procedure Detach_Interrupt_Entries
(T
: Task_Id
) is
385 Interrupt_Manager
.Detach_Interrupt_Entries
(T
);
386 end Detach_Interrupt_Entries
;
388 ----------------------
389 -- Exchange_Handler --
390 ----------------------
392 -- Calling this procedure with New_Handler = null and Static = True
393 -- means we want to detach the current handler regardless of the
394 -- previous handler's binding status (ie. do not care if it is a
395 -- dynamic or static handler).
397 -- This option is needed so that during the finalization of a PO,
398 -- we can detach handlers attached through pragma Attach_Handler.
400 procedure Exchange_Handler
401 (Old_Handler
: out Parameterless_Handler
;
402 New_Handler
: Parameterless_Handler
;
403 Interrupt
: Interrupt_ID
;
404 Static
: Boolean := False)
407 if Is_Reserved
(Interrupt
) then
408 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
409 Interrupt_ID
'Image (Interrupt
) & " is reserved");
412 Interrupt_Manager
.Exchange_Handler
413 (Old_Handler
, New_Handler
, Interrupt
, Static
);
414 end Exchange_Handler
;
420 procedure Finalize
(Object
: in out Static_Interrupt_Protection
) is
422 -- ??? loop to be executed only when we're not doing library level
423 -- finalization, since in this case all interrupt tasks are gone.
425 if not Interrupt_Manager
'Terminated then
426 for N
in reverse Object
.Previous_Handlers
'Range loop
427 Interrupt_Manager
.Attach_Handler
428 (New_Handler
=> Object
.Previous_Handlers
(N
).Handler
,
429 Interrupt
=> Object
.Previous_Handlers
(N
).Interrupt
,
430 Static
=> Object
.Previous_Handlers
(N
).Static
,
431 Restoration
=> True);
435 Tasking
.Protected_Objects
.Entries
.Finalize
436 (Tasking
.Protected_Objects
.Entries
.Protection_Entries
(Object
));
439 -------------------------------------
440 -- Has_Interrupt_Or_Attach_Handler --
441 -------------------------------------
443 -- Need comments as to why these always return True ???
445 function Has_Interrupt_Or_Attach_Handler
446 (Object
: access Dynamic_Interrupt_Protection
) return Boolean
448 pragma Unreferenced
(Object
);
451 end Has_Interrupt_Or_Attach_Handler
;
453 function Has_Interrupt_Or_Attach_Handler
454 (Object
: access Static_Interrupt_Protection
) return Boolean
456 pragma Unreferenced
(Object
);
459 end Has_Interrupt_Or_Attach_Handler
;
461 ----------------------
462 -- Ignore_Interrupt --
463 ----------------------
465 procedure Ignore_Interrupt
(Interrupt
: Interrupt_ID
) is
467 if Is_Reserved
(Interrupt
) then
468 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
469 Interrupt_ID
'Image (Interrupt
) & " is reserved");
472 Interrupt_Manager
.Ignore_Interrupt
(Interrupt
);
473 end Ignore_Interrupt
;
475 ----------------------
476 -- Install_Handlers --
477 ----------------------
479 procedure Install_Handlers
480 (Object
: access Static_Interrupt_Protection
;
481 New_Handlers
: New_Handler_Array
)
484 for N
in New_Handlers
'Range loop
486 -- We need a lock around this ???
488 Object
.Previous_Handlers
(N
).Interrupt
:= New_Handlers
(N
).Interrupt
;
489 Object
.Previous_Handlers
(N
).Static
:= User_Handler
490 (New_Handlers
(N
).Interrupt
).Static
;
492 -- We call Exchange_Handler and not directly Interrupt_Manager.
493 -- Exchange_Handler so we get the Is_Reserved check.
496 (Old_Handler
=> Object
.Previous_Handlers
(N
).Handler
,
497 New_Handler
=> New_Handlers
(N
).Handler
,
498 Interrupt
=> New_Handlers
(N
).Interrupt
,
501 end Install_Handlers
;
507 function Is_Blocked
(Interrupt
: Interrupt_ID
) return Boolean is
509 if Is_Reserved
(Interrupt
) then
510 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
511 Interrupt_ID
'Image (Interrupt
) & " is reserved");
514 return Blocked
(Interrupt
);
517 -----------------------
518 -- Is_Entry_Attached --
519 -----------------------
521 function Is_Entry_Attached
(Interrupt
: Interrupt_ID
) return Boolean is
523 if Is_Reserved
(Interrupt
) then
524 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
525 Interrupt_ID
'Image (Interrupt
) & " is reserved");
528 return User_Entry
(Interrupt
).T
/= Null_Task
;
529 end Is_Entry_Attached
;
531 -------------------------
532 -- Is_Handler_Attached --
533 -------------------------
535 function Is_Handler_Attached
(Interrupt
: Interrupt_ID
) return Boolean is
537 if Is_Reserved
(Interrupt
) then
538 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
539 Interrupt_ID
'Image (Interrupt
) & " is reserved");
542 return User_Handler
(Interrupt
).H
/= null;
543 end Is_Handler_Attached
;
549 function Is_Ignored
(Interrupt
: Interrupt_ID
) return Boolean is
551 if Is_Reserved
(Interrupt
) then
552 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
553 Interrupt_ID
'Image (Interrupt
) & " is reserved");
556 return Ignored
(Interrupt
);
563 function Is_Registered
(Handler
: Parameterless_Handler
) return Boolean is
565 type Fat_Ptr
is record
566 Object_Addr
: System
.Address
;
567 Handler_Addr
: System
.Address
;
570 function To_Fat_Ptr
is new Unchecked_Conversion
571 (Parameterless_Handler
, Fat_Ptr
);
577 if Handler
= null then
581 Fat
:= To_Fat_Ptr
(Handler
);
583 Ptr
:= Registered_Handler_Head
;
585 while Ptr
/= null loop
586 if Ptr
.H
= Fat
.Handler_Addr
then
600 function Is_Reserved
(Interrupt
: Interrupt_ID
) return Boolean is
602 return IMNG
.Reserve
(IMNG
.Interrupt_ID
(Interrupt
));
609 function Reference
(Interrupt
: Interrupt_ID
) return System
.Address
is
611 if Is_Reserved
(Interrupt
) then
612 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
613 Interrupt_ID
'Image (Interrupt
) & " is reserved");
616 return Storage_Elements
.To_Address
617 (Storage_Elements
.Integer_Address
(Interrupt
));
620 ---------------------------------
621 -- Register_Interrupt_Handler --
622 ---------------------------------
624 procedure Register_Interrupt_Handler
(Handler_Addr
: System
.Address
) is
625 New_Node_Ptr
: R_Link
;
628 -- This routine registers the Handler as usable for Dynamic Interrupt
629 -- Handler. Routines attaching and detaching Handler dynamically should
630 -- first consult if the Handler is registered. A Program Error should
631 -- be raised if it is not registered.
633 -- The pragma Interrupt_Handler can only appear in the library level PO
634 -- definition and instantiation. Therefore, we do not need to implement
635 -- Unregistering operation. Neither we need to protect the queue
636 -- structure using a Lock.
638 pragma Assert
(Handler_Addr
/= System
.Null_Address
);
640 New_Node_Ptr
:= new Registered_Handler
;
641 New_Node_Ptr
.H
:= Handler_Addr
;
643 if Registered_Handler_Head
= null then
644 Registered_Handler_Head
:= New_Node_Ptr
;
645 Registered_Handler_Tail
:= New_Node_Ptr
;
648 Registered_Handler_Tail
.Next
:= New_Node_Ptr
;
649 Registered_Handler_Tail
:= New_Node_Ptr
;
651 end Register_Interrupt_Handler
;
653 -----------------------
654 -- Unblock_Interrupt --
655 -----------------------
657 procedure Unblock_Interrupt
(Interrupt
: Interrupt_ID
) is
659 if Is_Reserved
(Interrupt
) then
660 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
661 Interrupt_ID
'Image (Interrupt
) & " is reserved");
664 Interrupt_Manager
.Unblock_Interrupt
(Interrupt
);
665 end Unblock_Interrupt
;
671 function Unblocked_By
672 (Interrupt
: Interrupt_ID
) return System
.Tasking
.Task_Id
675 if Is_Reserved
(Interrupt
) then
676 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
677 Interrupt_ID
'Image (Interrupt
) & " is reserved");
680 return Last_Unblocker
(Interrupt
);
683 ------------------------
684 -- Unignore_Interrupt --
685 ------------------------
687 procedure Unignore_Interrupt
(Interrupt
: Interrupt_ID
) is
689 if Is_Reserved
(Interrupt
) then
690 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
691 Interrupt_ID
'Image (Interrupt
) & " is reserved");
694 Interrupt_Manager
.Unignore_Interrupt
(Interrupt
);
695 end Unignore_Interrupt
;
697 -----------------------
698 -- Interrupt_Manager --
699 -----------------------
701 task body Interrupt_Manager
is
703 ---------------------
704 -- Local Variables --
705 ---------------------
707 Intwait_Mask
: aliased IMNG
.Interrupt_Mask
;
708 Ret_Interrupt
: Interrupt_ID
;
709 Old_Mask
: aliased IMNG
.Interrupt_Mask
;
710 Old_Handler
: Parameterless_Handler
;
716 procedure Bind_Handler
(Interrupt
: Interrupt_ID
);
717 -- This procedure does not do anything if the Interrupt is blocked.
718 -- Otherwise, we have to interrupt Server_Task for status change through
721 procedure Unbind_Handler
(Interrupt
: Interrupt_ID
);
722 -- This procedure does not do anything if the Interrupt is blocked.
723 -- Otherwise, we have to interrupt Server_Task for status change
724 -- through abort interrupt.
726 procedure Unprotected_Exchange_Handler
727 (Old_Handler
: out Parameterless_Handler
;
728 New_Handler
: Parameterless_Handler
;
729 Interrupt
: Interrupt_ID
;
731 Restoration
: Boolean := False);
733 procedure Unprotected_Detach_Handler
734 (Interrupt
: Interrupt_ID
;
741 procedure Bind_Handler
(Interrupt
: Interrupt_ID
) is
743 if not Blocked
(Interrupt
) then
745 -- Mask this task for the given Interrupt so that all tasks
746 -- are masked for the Interrupt and the actuall delivery of the
747 -- Interrupt will be caught using "sigwait" by the
748 -- corresponding Server_Task.
750 IMOP
.Thread_Block_Interrupt
(IMNG
.Interrupt_ID
(Interrupt
));
752 -- We have installed a Handler or an Entry before we called
753 -- this procedure. If the Handler Task is waiting to be awakened,
754 -- do it here. Otherwise, the interrupt will be discarded.
756 POP
.Wakeup
(Server_ID
(Interrupt
), Interrupt_Server_Idle_Sleep
);
764 procedure Unbind_Handler
(Interrupt
: Interrupt_ID
) is
766 if not Blocked
(Interrupt
) then
768 -- Currently, there is a Handler or an Entry attached and
769 -- corresponding Server_Task is waiting on "sigwait."
770 -- We have to wake up the Server_Task and make it
771 -- wait on condition variable by sending an
772 -- Abort_Task_Interrupt
774 POP
.Abort_Task
(Server_ID
(Interrupt
));
776 -- Make sure corresponding Server_Task is out of its own
780 Interrupt_ID
(IMOP
.Interrupt_Wait
(Intwait_Mask
'Access));
783 (Ret_Interrupt
= Interrupt_ID
(IMNG
.Abort_Task_Interrupt
));
785 IMOP
.Install_Default_Action
(IMNG
.Interrupt_ID
(Interrupt
));
787 -- Unmake the Interrupt for this task in order to allow default
790 IMOP
.Thread_Unblock_Interrupt
(IMNG
.Interrupt_ID
(Interrupt
));
793 IMOP
.Install_Default_Action
(IMNG
.Interrupt_ID
(Interrupt
));
797 --------------------------------
798 -- Unprotected_Detach_Handler --
799 --------------------------------
801 procedure Unprotected_Detach_Handler
802 (Interrupt
: Interrupt_ID
;
805 Old_Handler
: Parameterless_Handler
;
808 if User_Entry
(Interrupt
).T
/= Null_Task
then
810 -- In case we have an Interrupt Entry installed.
811 -- raise a program error. (propagate it to the caller).
813 Raise_Exception
(Program_Error
'Identity,
814 "An interrupt entry is already installed");
817 -- Note : Static = True will pass the following check. That is the
818 -- case when we want to detach a handler regardless of the static
819 -- status of the current_Handler.
821 if not Static
and then User_Handler
(Interrupt
).Static
then
823 -- Tries to detach a static Interrupt Handler.
824 -- raise a program error.
826 Raise_Exception
(Program_Error
'Identity,
827 "Trying to detach a static Interrupt Handler");
830 -- The interrupt should no longer be ignored if
831 -- it was ever ignored.
833 Ignored
(Interrupt
) := False;
835 Old_Handler
:= User_Handler
(Interrupt
).H
;
839 User_Handler
(Interrupt
).H
:= null;
840 User_Handler
(Interrupt
).Static
:= False;
842 if Old_Handler
/= null then
843 Unbind_Handler
(Interrupt
);
845 end Unprotected_Detach_Handler
;
847 ----------------------------------
848 -- Unprotected_Exchange_Handler --
849 ----------------------------------
851 procedure Unprotected_Exchange_Handler
852 (Old_Handler
: out Parameterless_Handler
;
853 New_Handler
: Parameterless_Handler
;
854 Interrupt
: Interrupt_ID
;
856 Restoration
: Boolean := False)
859 if User_Entry
(Interrupt
).T
/= Null_Task
then
861 -- In case we have an Interrupt Entry already installed.
862 -- raise a program error. (propagate it to the caller).
864 Raise_Exception
(Program_Error
'Identity,
865 "An interrupt is already installed");
868 -- Note : A null handler with Static = True will pass the
869 -- following check. That is the case when we want to Detach a
870 -- handler regardless of the Static status of the current_Handler.
872 -- We don't check anything if Restoration is True, since we
873 -- may be detaching a static handler to restore a dynamic one.
875 if not Restoration
and then not Static
877 -- Tries to overwrite a static Interrupt Handler with a
880 and then (User_Handler
(Interrupt
).Static
882 -- The new handler is not specified as an
883 -- Interrupt Handler by a pragma.
885 or else not Is_Registered
(New_Handler
))
887 Raise_Exception
(Program_Error
'Identity,
888 "Trying to overwrite a static Interrupt Handler with a " &
892 -- The interrupt should no longer be ingnored if
893 -- it was ever ignored.
895 Ignored
(Interrupt
) := False;
897 -- Save the old handler
899 Old_Handler
:= User_Handler
(Interrupt
).H
;
903 User_Handler
(Interrupt
).H
:= New_Handler
;
905 if New_Handler
= null then
907 -- The null handler means we are detaching the handler.
909 User_Handler
(Interrupt
).Static
:= False;
912 User_Handler
(Interrupt
).Static
:= Static
;
915 -- Invoke a corresponding Server_Task if not yet created.
916 -- Place Task_Id info in Server_ID array.
918 if Server_ID
(Interrupt
) = Null_Task
then
920 -- When a new Server_Task is created, it should have its
921 -- signal mask set to the All_Tasks_Mask.
923 IMOP
.Set_Interrupt_Mask
924 (IMOP
.All_Tasks_Mask
'Access, Old_Mask
'Access);
925 Access_Hold
:= new Server_Task
(Interrupt
);
926 IMOP
.Set_Interrupt_Mask
(Old_Mask
'Access);
928 Server_ID
(Interrupt
) := To_System
(Access_Hold
.all'Identity);
931 if New_Handler
= null then
932 if Old_Handler
/= null then
933 Unbind_Handler
(Interrupt
);
939 if Old_Handler
= null then
940 Bind_Handler
(Interrupt
);
942 end Unprotected_Exchange_Handler
;
944 -- Start of processing for Interrupt_Manager
947 -- By making this task independent of master, when the process
948 -- goes away, the Interrupt_Manager will terminate gracefully.
950 System
.Tasking
.Utilities
.Make_Independent
;
952 -- Environment task gets its own interrupt mask, saves it,
953 -- and then masks all interrupts except the Keep_Unmasked set.
955 -- During rendezvous, the Interrupt_Manager receives the old
956 -- interrupt mask of the environment task, and sets its own
957 -- interrupt mask to that value.
959 -- The environment task will call the entry of Interrupt_Manager some
960 -- during elaboration of the body of this package.
962 accept Initialize
(Mask
: IMNG
.Interrupt_Mask
) do
964 The_Mask
: aliased IMNG
.Interrupt_Mask
;
967 IMOP
.Copy_Interrupt_Mask
(The_Mask
, Mask
);
968 IMOP
.Set_Interrupt_Mask
(The_Mask
'Access);
972 -- Note: All tasks in RTS will have all the Reserve Interrupts
973 -- being masked (except the Interrupt_Manager) and Keep_Unmasked
974 -- unmasked when created.
976 -- Abort_Task_Interrupt is one of the Interrupt unmasked
977 -- in all tasks. We mask the Interrupt in this particular task
978 -- so that "sigwait" is possible to catch an explicitely sent
979 -- Abort_Task_Interrupt from the Server_Tasks.
981 -- This sigwaiting is needed so that we make sure a Server_Task is
982 -- out of its own sigwait state. This extra synchronization is
983 -- necessary to prevent following senarios.
985 -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to the
986 -- Server_Task then changes its own interrupt mask (OS level).
987 -- If an interrupt (corresponding to the Server_Task) arrives
988 -- in the nean time we have the Interrupt_Manager umnasked and
989 -- the Server_Task waiting on sigwait.
991 -- 2) For unbinding handler, we install a default action in the
992 -- Interrupt_Manager. POSIX.1c states that the result of using
993 -- "sigwait" and "sigaction" simaltaneously on the same interrupt
994 -- is undefined. Therefore, we need to be informed from the
995 -- Server_Task of the fact that the Server_Task is out of its
998 IMOP
.Empty_Interrupt_Mask
(Intwait_Mask
'Access);
999 IMOP
.Add_To_Interrupt_Mask
1000 (Intwait_Mask
'Access, IMNG
.Abort_Task_Interrupt
);
1001 IMOP
.Thread_Block_Interrupt
1002 (IMNG
.Abort_Task_Interrupt
);
1005 -- A block is needed to absorb Program_Error exception
1009 accept Attach_Handler
1010 (New_Handler
: Parameterless_Handler
;
1011 Interrupt
: Interrupt_ID
;
1013 Restoration
: Boolean := False)
1015 Unprotected_Exchange_Handler
1016 (Old_Handler
, New_Handler
, Interrupt
, Static
, Restoration
);
1020 accept Exchange_Handler
1021 (Old_Handler
: out Parameterless_Handler
;
1022 New_Handler
: Parameterless_Handler
;
1023 Interrupt
: Interrupt_ID
;
1026 Unprotected_Exchange_Handler
1027 (Old_Handler
, New_Handler
, Interrupt
, Static
);
1028 end Exchange_Handler
;
1031 accept Detach_Handler
1032 (Interrupt
: Interrupt_ID
;
1035 Unprotected_Detach_Handler
(Interrupt
, Static
);
1039 accept Bind_Interrupt_To_Entry
1041 E
: Task_Entry_Index
;
1042 Interrupt
: Interrupt_ID
)
1044 -- if there is a binding already (either a procedure or an
1045 -- entry), raise Program_Error (propagate it to the caller).
1047 if User_Handler
(Interrupt
).H
/= null
1048 or else User_Entry
(Interrupt
).T
/= Null_Task
1050 Raise_Exception
(Program_Error
'Identity,
1051 "A binding for this interrupt is already present");
1054 -- The interrupt should no longer be ingnored if
1055 -- it was ever ignored.
1057 Ignored
(Interrupt
) := False;
1058 User_Entry
(Interrupt
) := Entry_Assoc
'(T => T, E => E);
1060 -- Indicate the attachment of Interrupt Entry in ATCB.
1061 -- This is need so that when an Interrupt Entry task
1062 -- terminates the binding can be cleaned. The call to
1063 -- unbinding must be made by the task before it terminates.
1065 T.Interrupt_Entry := True;
1067 -- Invoke a corresponding Server_Task if not yet created.
1068 -- Place Task_Id info in Server_ID array.
1070 if Server_ID (Interrupt) = Null_Task then
1072 -- When a new Server_Task is created, it should have its
1073 -- signal mask set to the All_Tasks_Mask.
1075 IMOP.Set_Interrupt_Mask
1076 (IMOP.All_Tasks_Mask'Access, Old_Mask'Access);
1077 Access_Hold := new Server_Task (Interrupt);
1078 IMOP.Set_Interrupt_Mask (Old_Mask'Access);
1079 Server_ID (Interrupt) :=
1080 To_System (Access_Hold.all'Identity);
1083 Bind_Handler (Interrupt);
1084 end Bind_Interrupt_To_Entry;
1087 accept Detach_Interrupt_Entries (T : Task_Id) do
1088 for J in Interrupt_ID'Range loop
1089 if not Is_Reserved (J) then
1090 if User_Entry (J).T = T then
1092 -- The interrupt should no longer be ingnored if
1093 -- it was ever ignored.
1095 Ignored (J) := False;
1096 User_Entry (J) := Entry_Assoc'
1097 (T
=> Null_Task
, E
=> Null_Task_Entry
);
1103 -- Indicate in ATCB that no Interrupt Entries are attached
1105 T
.Interrupt_Entry
:= False;
1106 end Detach_Interrupt_Entries
;
1109 accept Block_Interrupt
(Interrupt
: Interrupt_ID
) do
1110 if Blocked
(Interrupt
) then
1114 Blocked
(Interrupt
) := True;
1115 Last_Unblocker
(Interrupt
) := Null_Task
;
1117 -- Mask this task for the given Interrupt so that all tasks
1118 -- are masked for the Interrupt.
1120 IMOP
.Thread_Block_Interrupt
(IMNG
.Interrupt_ID
(Interrupt
));
1122 if User_Handler
(Interrupt
).H
/= null
1123 or else User_Entry
(Interrupt
).T
/= Null_Task
1125 -- This is the case where the Server_Task is waiting
1126 -- on "sigwait." Wake it up by sending an
1127 -- Abort_Task_Interrupt so that the Server_Task
1130 POP
.Abort_Task
(Server_ID
(Interrupt
));
1132 -- Make sure corresponding Server_Task is out of its own
1135 Ret_Interrupt
:= Interrupt_ID
1136 (IMOP
.Interrupt_Wait
(Intwait_Mask
'Access));
1139 Interrupt_ID
(IMNG
.Abort_Task_Interrupt
));
1141 end Block_Interrupt
;
1144 accept Unblock_Interrupt
(Interrupt
: Interrupt_ID
) do
1145 if not Blocked
(Interrupt
) then
1149 Blocked
(Interrupt
) := False;
1150 Last_Unblocker
(Interrupt
) :=
1151 To_System
(Unblock_Interrupt
'Caller);
1153 if User_Handler
(Interrupt
).H
= null
1154 and then User_Entry
(Interrupt
).T
= Null_Task
1156 -- No handler is attached. Unmask the Interrupt so that
1157 -- the default action can be carried out.
1159 IMOP
.Thread_Unblock_Interrupt
1160 (IMNG
.Interrupt_ID
(Interrupt
));
1163 -- The Server_Task must be waiting on the Cond variable
1164 -- since it was being blocked and an Interrupt Hander or
1165 -- an Entry was there. Wake it up and let it change
1166 -- it place of waiting according to its new state.
1168 POP
.Wakeup
(Server_ID
(Interrupt
),
1169 Interrupt_Server_Blocked_Interrupt_Sleep
);
1171 end Unblock_Interrupt
;
1174 accept Ignore_Interrupt
(Interrupt
: Interrupt_ID
) do
1175 if Ignored
(Interrupt
) then
1179 Ignored
(Interrupt
) := True;
1181 -- If there is a handler associated with the Interrupt,
1182 -- detach it first. In this way we make sure that the
1183 -- Server_Task is not on sigwait. This is legal since
1184 -- Unignore_Interrupt is to install the default action.
1186 if User_Handler
(Interrupt
).H
/= null then
1187 Unprotected_Detach_Handler
1188 (Interrupt
=> Interrupt
, Static
=> True);
1190 elsif User_Entry
(Interrupt
).T
/= Null_Task
then
1191 User_Entry
(Interrupt
) := Entry_Assoc
'
1192 (T => Null_Task, E => Null_Task_Entry);
1193 Unbind_Handler (Interrupt);
1196 IMOP.Install_Ignore_Action (IMNG.Interrupt_ID (Interrupt));
1197 end Ignore_Interrupt;
1200 accept Unignore_Interrupt (Interrupt : Interrupt_ID) do
1201 Ignored (Interrupt) := False;
1203 -- If there is a handler associated with the Interrupt,
1204 -- detach it first. In this way we make sure that the
1205 -- Server_Task is not on sigwait. This is legal since
1206 -- Unignore_Interrupt is to install the default action.
1208 if User_Handler (Interrupt).H /= null then
1209 Unprotected_Detach_Handler
1210 (Interrupt => Interrupt, Static => True);
1212 elsif User_Entry (Interrupt).T /= Null_Task then
1213 User_Entry (Interrupt) := Entry_Assoc'
1214 (T
=> Null_Task
, E
=> Null_Task_Entry
);
1215 Unbind_Handler
(Interrupt
);
1218 IMOP
.Install_Default_Action
(IMNG
.Interrupt_ID
(Interrupt
));
1219 end Unignore_Interrupt
;
1223 -- If there is a program error we just want to propagate it to
1224 -- the caller and do not want to stop this task.
1226 when Program_Error
=>
1230 pragma Assert
(False);
1234 end Interrupt_Manager
;
1240 task body Server_Task
is
1241 Intwait_Mask
: aliased IMNG
.Interrupt_Mask
;
1242 Ret_Interrupt
: Interrupt_ID
;
1243 Self_ID
: constant Task_Id
:= Self
;
1244 Tmp_Handler
: Parameterless_Handler
;
1246 Tmp_Entry_Index
: Task_Entry_Index
;
1249 -- By making this task independent of master, when the process
1250 -- goes away, the Server_Task will terminate gracefully.
1252 System
.Tasking
.Utilities
.Make_Independent
;
1254 -- Install default action in system level.
1256 IMOP
.Install_Default_Action
(IMNG
.Interrupt_ID
(Interrupt
));
1258 -- Note: All tasks in RTS will have all the Reserve Interrupts
1259 -- being masked (except the Interrupt_Manager) and Keep_Unmasked
1260 -- unmasked when created.
1262 -- Abort_Task_Interrupt is one of the Interrupt unmasked
1263 -- in all tasks. We mask the Interrupt in this particular task
1264 -- so that "sigwait" is possible to catch an explicitely sent
1265 -- Abort_Task_Interrupt from the Interrupt_Manager.
1267 -- There are two Interrupt interrupts that this task catch through
1268 -- "sigwait." One is the Interrupt this task is designated to catch
1269 -- in order to execure user handler or entry. The other one is the
1270 -- Abort_Task_Interrupt. This interrupt is being sent from the
1271 -- Interrupt_Manager to inform status changes (e.g: become Blocked,
1272 -- Handler or Entry is to be detached).
1274 -- Prepare a mask to used for sigwait.
1276 IMOP
.Empty_Interrupt_Mask
(Intwait_Mask
'Access);
1278 IMOP
.Add_To_Interrupt_Mask
1279 (Intwait_Mask
'Access, IMNG
.Interrupt_ID
(Interrupt
));
1281 IMOP
.Add_To_Interrupt_Mask
1282 (Intwait_Mask
'Access, IMNG
.Abort_Task_Interrupt
);
1284 IMOP
.Thread_Block_Interrupt
1285 (IMNG
.Abort_Task_Interrupt
);
1287 PIO
.Set_Interrupt_ID
(IMNG
.Interrupt_ID
(Interrupt
), Self_ID
);
1290 System
.Tasking
.Initialization
.Defer_Abort
(Self_ID
);
1296 POP
.Write_Lock
(Self_ID
);
1298 if User_Handler
(Interrupt
).H
= null
1299 and then User_Entry
(Interrupt
).T
= Null_Task
1301 -- No Interrupt binding. If there is an interrupt,
1302 -- Interrupt_Manager will take default action.
1304 Self_ID
.Common
.State
:= Interrupt_Server_Blocked_Interrupt_Sleep
;
1305 POP
.Sleep
(Self_ID
, Interrupt_Server_Idle_Sleep
);
1306 Self_ID
.Common
.State
:= Runnable
;
1308 elsif Blocked
(Interrupt
) then
1310 -- Interrupt is blocked. Stay here, so we won't catch
1313 Self_ID
.Common
.State
:= Interrupt_Server_Blocked_Interrupt_Sleep
;
1314 POP
.Sleep
(Self_ID
, Interrupt_Server_Blocked_Interrupt_Sleep
);
1315 Self_ID
.Common
.State
:= Runnable
;
1318 -- A Handler or an Entry is installed. At this point all tasks
1319 -- mask for the Interrupt is masked. Catch the Interrupt using
1322 -- This task may wake up from sigwait by receiving an interrupt
1323 -- (Abort_Task_Interrupt) from the Interrupt_Manager for unbinding
1324 -- a Procedure Handler or an Entry. Or it could be a wake up
1325 -- from status change (Unblocked -> Blocked). If that is not
1326 -- the case, we should exceute the attached Procedure or Entry.
1328 POP
.Unlock
(Self_ID
);
1335 Interrupt_ID
(IMOP
.Interrupt_Wait
(Intwait_Mask
'Access));
1337 if Ret_Interrupt
= Interrupt_ID
(IMNG
.Abort_Task_Interrupt
) then
1339 -- Inform the Interrupt_Manager of wakeup from above sigwait.
1341 POP
.Abort_Task
(Interrupt_Manager_ID
);
1347 POP
.Write_Lock
(Self_ID
);
1354 POP
.Write_Lock
(Self_ID
);
1356 if Ret_Interrupt
/= Interrupt
then
1358 -- On some systems (e.g. recent linux kernels), sigwait
1359 -- may return unexpectedly (with errno set to EINTR).
1364 -- Even though we have received an Interrupt the status may
1365 -- have changed already before we got the Self_ID lock above
1366 -- Therefore we make sure a Handler or an Entry is still
1367 -- there and make appropriate call.
1369 -- If there is no calls to make we need to regenerate the
1370 -- Interrupt in order not to lose it.
1372 if User_Handler
(Interrupt
).H
/= null then
1373 Tmp_Handler
:= User_Handler
(Interrupt
).H
;
1375 -- RTS calls should not be made with self being locked.
1377 POP
.Unlock
(Self_ID
);
1389 POP
.Write_Lock
(Self_ID
);
1391 elsif User_Entry
(Interrupt
).T
/= Null_Task
then
1392 Tmp_ID
:= User_Entry
(Interrupt
).T
;
1393 Tmp_Entry_Index
:= User_Entry
(Interrupt
).E
;
1395 -- RTS calls should not be made with self being locked.
1401 POP
.Unlock
(Self_ID
);
1403 System
.Tasking
.Rendezvous
.Call_Simple
1404 (Tmp_ID
, Tmp_Entry_Index
, System
.Null_Address
);
1406 POP
.Write_Lock
(Self_ID
);
1413 -- This is a situation that this task wakes up receiving
1414 -- an Interrupt and before it gets the lock the Interrupt
1415 -- is blocked. We do not want to lose the interrupt in
1416 -- this case so we regenerate the Interrupt to process
1419 IMOP
.Interrupt_Self_Process
1420 (IMNG
.Interrupt_ID
(Interrupt
));
1426 POP
.Unlock
(Self_ID
);
1432 System
.Tasking
.Initialization
.Undefer_Abort
(Self_ID
);
1434 if Self_ID
.Pending_Action
then
1435 Initialization
.Do_Pending_Action
(Self_ID
);
1438 -- Undefer abort here to allow a window for this task to be aborted
1439 -- at the time of system shutdown. We also explicitely test for
1440 -- Pending_Action in case System.Parameters.No_Abort is True.
1445 -- Elaboration code for package System.Interrupts
1448 -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent.
1450 Interrupt_Manager_ID
:= To_System
(Interrupt_Manager
'Identity);
1452 -- During the elaboration of this package body we want the RTS
1453 -- to inherit the interrupt mask from the Environment Task.
1455 IMOP
.Setup_Interrupt_Mask
;
1457 -- The environment task should have gotten its mask from the enclosing
1458 -- process during the RTS start up. (See processing in s-inmaop.adb). Pass
1459 -- the Interrupt_Mask of the environment task to the Interrupt_Manager.
1461 -- Note : At this point we know that all tasks are masked for non-reserved
1462 -- signals. Only the Interrupt_Manager will have masks set up differently
1463 -- inheriting the original environment task's mask.
1465 Interrupt_Manager
.Initialize
(IMOP
.Environment_Mask
);
1466 end System
.Interrupts
;