1 ------------------------------------------------------------------------------
3 -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- S Y S T E M . I N T E R R U P T S --
10 -- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
12 -- GNARL is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNARL; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- GNARL was developed by the GNARL team at Florida State University. It is --
31 -- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
33 ------------------------------------------------------------------------------
35 -- This is an OpenVMS/Alpha version of this package.
39 -- Once we associate a Server_Task with an interrupt, the task never
40 -- goes away, and we never remove the association.
42 -- There is no more than one interrupt per Server_Task and no more than
43 -- one Server_Task per interrupt.
45 -- Within this package, the lock L is used to protect the various status
46 -- tables. If there is a Server_Task associated with an interrupt, we use
47 -- the per-task lock of the Server_Task instead so that we protect the
48 -- status between Interrupt_Manager and Server_Task. Protection among
49 -- service requests are done using User Request to Interrupt_Manager
52 with Ada
.Task_Identification
;
53 -- used for Task_ID type
56 -- used for Raise_Exception
58 with System
.Task_Primitives
;
62 with System
.Interrupt_Management
;
66 -- Abort_Task_Interrupt
68 with System
.Interrupt_Management
.Operations
;
69 -- used for Thread_Block_Interrupt
70 -- Thread_Unblock_Interrupt
71 -- Install_Default_Action
72 -- Install_Ignore_Action
73 -- Copy_Interrupt_Mask
75 -- Empty_Interrupt_Mask
76 -- Fill_Interrupt_Mask
77 -- Add_To_Interrupt_Mask
78 -- Delete_From_Interrupt_Mask
80 -- Interrupt_Self_Process
85 pragma Elaborate_All
(System
.Interrupt_Management
.Operations
);
87 with System
.Task_Primitives
.Operations
;
88 -- used for Write_Lock
95 with System
.Task_Primitives
.Interrupt_Operations
;
96 -- used for Set_Interrupt_ID
98 with System
.Storage_Elements
;
99 -- used for To_Address
108 -- Interrupt_Manager_ID
110 with System
.Tasking
.Utilities
;
111 -- used for Make_Independent
113 with System
.Tasking
.Rendezvous
;
114 -- used for Call_Simple
115 pragma Elaborate_All
(System
.Tasking
.Rendezvous
);
117 with System
.Tasking
.Initialization
;
118 -- used for Defer_Abort
121 with System
.Parameters
;
122 -- used for Single_Lock
124 with Unchecked_Conversion
;
126 package body System
.Interrupts
is
129 use System
.Parameters
;
132 package PRI
renames System
.Task_Primitives
;
133 package POP
renames System
.Task_Primitives
.Operations
;
134 package PIO
renames System
.Task_Primitives
.Interrupt_Operations
;
135 package IMNG
renames System
.Interrupt_Management
;
136 package IMOP
renames System
.Interrupt_Management
.Operations
;
138 function To_System
is new Unchecked_Conversion
139 (Ada
.Task_Identification
.Task_Id
, Task_ID
);
145 -- WARNING: System.Tasking.Stages performs calls to this task
146 -- with low-level constructs. Do not change this spec without synchro-
149 task Interrupt_Manager
is
150 entry Detach_Interrupt_Entries
(T
: Task_ID
);
152 entry Initialize
(Mask
: IMNG
.Interrupt_Mask
);
155 (New_Handler
: in Parameterless_Handler
;
156 Interrupt
: in Interrupt_ID
;
158 Restoration
: in Boolean := False);
160 entry Exchange_Handler
161 (Old_Handler
: out Parameterless_Handler
;
162 New_Handler
: in Parameterless_Handler
;
163 Interrupt
: in Interrupt_ID
;
164 Static
: in Boolean);
167 (Interrupt
: in Interrupt_ID
;
168 Static
: in Boolean);
170 entry Bind_Interrupt_To_Entry
172 E
: Task_Entry_Index
;
173 Interrupt
: Interrupt_ID
);
175 entry Block_Interrupt
(Interrupt
: Interrupt_ID
);
177 entry Unblock_Interrupt
(Interrupt
: Interrupt_ID
);
179 entry Ignore_Interrupt
(Interrupt
: Interrupt_ID
);
181 entry Unignore_Interrupt
(Interrupt
: Interrupt_ID
);
183 pragma Interrupt_Priority
(System
.Interrupt_Priority
'Last);
184 end Interrupt_Manager
;
186 task type Server_Task
(Interrupt
: Interrupt_ID
) is
187 pragma Priority
(System
.Interrupt_Priority
'Last);
190 type Server_Task_Access
is access Server_Task
;
192 --------------------------------
193 -- Local Types and Variables --
194 --------------------------------
196 type Entry_Assoc
is record
198 E
: Task_Entry_Index
;
201 type Handler_Assoc
is record
202 H
: Parameterless_Handler
;
203 Static
: Boolean; -- Indicates static binding;
206 User_Handler
: array (Interrupt_ID
'Range) of Handler_Assoc
:=
207 (others => (null, Static
=> False));
208 pragma Volatile_Components
(User_Handler
);
209 -- Holds the protected procedure handler (if any) and its Static
210 -- information for each interrupt. A handler is a Static one if
211 -- it is specified through the pragma Attach_Handler.
212 -- Attach_Handler. Otherwise, not static)
214 User_Entry
: array (Interrupt_ID
'Range) of Entry_Assoc
:=
215 (others => (T
=> Null_Task
, E
=> Null_Task_Entry
));
216 pragma Volatile_Components
(User_Entry
);
217 -- Holds the task and entry index (if any) for each interrupt
219 Blocked
: array (Interrupt_ID
'Range) of Boolean := (others => False);
220 pragma Volatile_Components
(Blocked
);
221 -- True iff the corresponding interrupt is blocked in the process level
223 Ignored
: array (Interrupt_ID
'Range) of Boolean := (others => False);
224 pragma Volatile_Components
(Ignored
);
225 -- True iff the corresponding interrupt is blocked in the process level
228 array (Interrupt_ID
'Range) of Task_ID
:= (others => Null_Task
);
229 pragma Volatile_Components
(Last_Unblocker
);
230 -- Holds the ID of the last Task which Unblocked this Interrupt.
231 -- It contains Null_Task if no tasks have ever requested the
232 -- Unblocking operation or the Interrupt is currently Blocked.
234 Server_ID
: array (Interrupt_ID
'Range) of Task_ID
:=
235 (others => Null_Task
);
236 pragma Atomic_Components
(Server_ID
);
237 -- Holds the Task_ID of the Server_Task for each interrupt.
238 -- Task_ID is needed to accomplish locking per Interrupt base. Also
239 -- is needed to decide whether to create a new Server_Task.
241 -- Type and Head, Tail of the list containing Registered Interrupt
242 -- Handlers. These definitions are used to register the handlers
243 -- specified by the pragma Interrupt_Handler.
245 type Registered_Handler
;
246 type R_Link
is access all Registered_Handler
;
248 type Registered_Handler
is record
249 H
: System
.Address
:= System
.Null_Address
;
250 Next
: R_Link
:= null;
253 Registered_Handler_Head
: R_Link
:= null;
254 Registered_Handler_Tail
: R_Link
:= null;
256 Access_Hold
: Server_Task_Access
;
257 -- variable used to allocate Server_Task using "new".
259 -----------------------
260 -- Local Subprograms --
261 -----------------------
263 function Is_Registered
(Handler
: Parameterless_Handler
) return Boolean;
264 -- See if the Handler has been "pragma"ed using Interrupt_Handler.
265 -- Always consider a null handler as registered.
267 --------------------------------
268 -- Register_Interrupt_Handler --
269 --------------------------------
271 procedure Register_Interrupt_Handler
(Handler_Addr
: System
.Address
) is
272 New_Node_Ptr
: R_Link
;
274 -- This routine registers the Handler as usable for Dynamic
275 -- Interrupt Handler. Routines attaching and detaching Handler
276 -- dynamically should first consult if the Handler is rgistered.
277 -- A Program Error should be raised if it is not registered.
279 -- The pragma Interrupt_Handler can only appear in the library
280 -- level PO definition and instantiation. Therefore, we do not need
281 -- to implement Unregistering operation. Neither we need to
282 -- protect the queue structure using a Lock.
284 pragma Assert
(Handler_Addr
/= System
.Null_Address
);
286 New_Node_Ptr
:= new Registered_Handler
;
287 New_Node_Ptr
.H
:= Handler_Addr
;
289 if Registered_Handler_Head
= null then
290 Registered_Handler_Head
:= New_Node_Ptr
;
291 Registered_Handler_Tail
:= New_Node_Ptr
;
294 Registered_Handler_Tail
.Next
:= New_Node_Ptr
;
295 Registered_Handler_Tail
:= New_Node_Ptr
;
297 end Register_Interrupt_Handler
;
303 function Is_Registered
(Handler
: Parameterless_Handler
) return Boolean is
304 type Fat_Ptr
is record
305 Object_Addr
: System
.Address
;
306 Handler_Addr
: System
.Address
;
309 function To_Fat_Ptr
is new Unchecked_Conversion
310 (Parameterless_Handler
, Fat_Ptr
);
316 if Handler
= null then
320 Fat
:= To_Fat_Ptr
(Handler
);
322 Ptr
:= Registered_Handler_Head
;
324 while (Ptr
/= null) loop
325 if Ptr
.H
= Fat
.Handler_Addr
then
340 function Is_Reserved
(Interrupt
: Interrupt_ID
) return Boolean is
342 return IMNG
.Reserve
(IMNG
.Interrupt_ID
(Interrupt
));
345 -----------------------
346 -- Is_Entry_Attached --
347 -----------------------
349 function Is_Entry_Attached
(Interrupt
: Interrupt_ID
) return Boolean is
351 if Is_Reserved
(Interrupt
) then
352 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
353 Interrupt_ID
'Image (Interrupt
) & " is reserved");
356 return User_Entry
(Interrupt
).T
/= Null_Task
;
357 end Is_Entry_Attached
;
359 -------------------------
360 -- Is_Handler_Attached --
361 -------------------------
363 function Is_Handler_Attached
(Interrupt
: Interrupt_ID
) return Boolean is
365 if Is_Reserved
(Interrupt
) then
366 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
367 Interrupt_ID
'Image (Interrupt
) & " is reserved");
370 return User_Handler
(Interrupt
).H
/= null;
371 end Is_Handler_Attached
;
377 function Is_Blocked
(Interrupt
: Interrupt_ID
) return Boolean is
379 if Is_Reserved
(Interrupt
) then
380 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
381 Interrupt_ID
'Image (Interrupt
) & " is reserved");
384 return Blocked
(Interrupt
);
391 function Is_Ignored
(Interrupt
: Interrupt_ID
) return Boolean is
393 if Is_Reserved
(Interrupt
) then
394 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
395 Interrupt_ID
'Image (Interrupt
) & " is reserved");
398 return Ignored
(Interrupt
);
401 ---------------------
402 -- Current_Handler --
403 ---------------------
405 function Current_Handler
(Interrupt
: Interrupt_ID
)
406 return Parameterless_Handler
is
408 if Is_Reserved
(Interrupt
) then
409 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
410 Interrupt_ID
'Image (Interrupt
) & " is reserved");
413 -- ??? Since Parameterless_Handler is not Atomic, the
414 -- current implementation is wrong. We need a new service in
415 -- Interrupt_Manager to ensure atomicity.
417 return User_Handler
(Interrupt
).H
;
424 -- Calling this procedure with New_Handler = null and Static = True
425 -- means we want to detach the current handler regardless of the
426 -- previous handler's binding status (ie. do not care if it is a
427 -- dynamic or static handler).
429 -- This option is needed so that during the finalization of a PO, we
430 -- can detach handlers attached through pragma Attach_Handler.
432 procedure Attach_Handler
433 (New_Handler
: in Parameterless_Handler
;
434 Interrupt
: in Interrupt_ID
;
435 Static
: in Boolean := False) is
437 if Is_Reserved
(Interrupt
) then
438 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
439 Interrupt_ID
'Image (Interrupt
) & " is reserved");
442 Interrupt_Manager
.Attach_Handler
(New_Handler
, Interrupt
, Static
);
446 ----------------------
447 -- Exchange_Handler --
448 ----------------------
450 -- Calling this procedure with New_Handler = null and Static = True
451 -- means we want to detach the current handler regardless of the
452 -- previous handler's binding status (ie. do not care if it is a
453 -- dynamic or static handler).
455 -- This option is needed so that during the finalization of a PO, we
456 -- can detach handlers attached through pragma Attach_Handler.
458 procedure Exchange_Handler
459 (Old_Handler
: out Parameterless_Handler
;
460 New_Handler
: in Parameterless_Handler
;
461 Interrupt
: in Interrupt_ID
;
462 Static
: in Boolean := False) is
464 if Is_Reserved
(Interrupt
) then
465 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
466 Interrupt_ID
'Image (Interrupt
) & " is reserved");
469 Interrupt_Manager
.Exchange_Handler
470 (Old_Handler
, New_Handler
, Interrupt
, Static
);
472 end Exchange_Handler
;
478 -- Calling this procedure with Static = True means we want to Detach the
479 -- current handler regardless of the previous handler's binding status
480 -- (i.e. do not care if it is a dynamic or static handler).
482 -- This option is needed so that during the finalization of a PO, we can
483 -- detach handlers attached through pragma Attach_Handler.
485 procedure Detach_Handler
486 (Interrupt
: in Interrupt_ID
;
487 Static
: in Boolean := False) is
489 if Is_Reserved
(Interrupt
) then
490 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
491 Interrupt_ID
'Image (Interrupt
) & " is reserved");
494 Interrupt_Manager
.Detach_Handler
(Interrupt
, Static
);
501 function Reference
(Interrupt
: Interrupt_ID
) return System
.Address
is
503 if Is_Reserved
(Interrupt
) then
504 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
505 Interrupt_ID
'Image (Interrupt
) & " is reserved");
508 return Storage_Elements
.To_Address
509 (Storage_Elements
.Integer_Address
(Interrupt
));
512 -----------------------------
513 -- Bind_Interrupt_To_Entry --
514 -----------------------------
516 -- This procedure raises a Program_Error if it tries to
517 -- bind an interrupt to which an Entry or a Procedure is
520 procedure Bind_Interrupt_To_Entry
522 E
: Task_Entry_Index
;
523 Int_Ref
: System
.Address
)
525 Interrupt
: constant Interrupt_ID
:=
526 Interrupt_ID
(Storage_Elements
.To_Integer
(Int_Ref
));
529 if Is_Reserved
(Interrupt
) then
530 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
531 Interrupt_ID
'Image (Interrupt
) & " is reserved");
534 Interrupt_Manager
.Bind_Interrupt_To_Entry
(T
, E
, Interrupt
);
536 end Bind_Interrupt_To_Entry
;
538 ------------------------------
539 -- Detach_Interrupt_Entries --
540 ------------------------------
542 procedure Detach_Interrupt_Entries
(T
: Task_ID
) is
544 Interrupt_Manager
.Detach_Interrupt_Entries
(T
);
545 end Detach_Interrupt_Entries
;
547 ---------------------
548 -- Block_Interrupt --
549 ---------------------
551 procedure Block_Interrupt
(Interrupt
: Interrupt_ID
) is
553 if Is_Reserved
(Interrupt
) then
554 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
555 Interrupt_ID
'Image (Interrupt
) & " is reserved");
558 Interrupt_Manager
.Block_Interrupt
(Interrupt
);
561 -----------------------
562 -- Unblock_Interrupt --
563 -----------------------
565 procedure Unblock_Interrupt
(Interrupt
: Interrupt_ID
) is
567 if Is_Reserved
(Interrupt
) then
568 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
569 Interrupt_ID
'Image (Interrupt
) & " is reserved");
572 Interrupt_Manager
.Unblock_Interrupt
(Interrupt
);
573 end Unblock_Interrupt
;
579 function Unblocked_By
580 (Interrupt
: Interrupt_ID
) return System
.Tasking
.Task_ID
is
582 if Is_Reserved
(Interrupt
) then
583 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
584 Interrupt_ID
'Image (Interrupt
) & " is reserved");
587 return Last_Unblocker
(Interrupt
);
590 ----------------------
591 -- Ignore_Interrupt --
592 ----------------------
594 procedure Ignore_Interrupt
(Interrupt
: Interrupt_ID
) is
596 if Is_Reserved
(Interrupt
) then
597 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
598 Interrupt_ID
'Image (Interrupt
) & " is reserved");
601 Interrupt_Manager
.Ignore_Interrupt
(Interrupt
);
602 end Ignore_Interrupt
;
604 ------------------------
605 -- Unignore_Interrupt --
606 ------------------------
608 procedure Unignore_Interrupt
(Interrupt
: Interrupt_ID
) is
610 if Is_Reserved
(Interrupt
) then
611 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
612 Interrupt_ID
'Image (Interrupt
) & " is reserved");
615 Interrupt_Manager
.Unignore_Interrupt
(Interrupt
);
616 end Unignore_Interrupt
;
618 -----------------------
619 -- Interrupt_Manager --
620 -----------------------
622 task body Interrupt_Manager
is
624 ---------------------
625 -- Local Variables --
626 ---------------------
628 Intwait_Mask
: aliased IMNG
.Interrupt_Mask
;
629 Ret_Interrupt
: Interrupt_ID
;
630 Old_Mask
: aliased IMNG
.Interrupt_Mask
;
631 Self_ID
: Task_ID
:= POP
.Self
;
633 ---------------------
635 ---------------------
637 procedure Unprotected_Exchange_Handler
638 (Old_Handler
: out Parameterless_Handler
;
639 New_Handler
: in Parameterless_Handler
;
640 Interrupt
: in Interrupt_ID
;
642 Restoration
: in Boolean := False);
644 procedure Unprotected_Detach_Handler
645 (Interrupt
: in Interrupt_ID
;
646 Static
: in Boolean);
648 ----------------------------------
649 -- Unprotected_Exchange_Handler --
650 ----------------------------------
652 procedure Unprotected_Exchange_Handler
653 (Old_Handler
: out Parameterless_Handler
;
654 New_Handler
: in Parameterless_Handler
;
655 Interrupt
: in Interrupt_ID
;
657 Restoration
: in Boolean := False) is
659 if User_Entry
(Interrupt
).T
/= Null_Task
then
660 -- In case we have an Interrupt Entry already installed.
661 -- raise a program error. (propagate it to the caller).
663 Raise_Exception
(Program_Error
'Identity,
664 "An interrupt is already installed");
667 -- Note : A null handler with Static = True will
668 -- pass the following check. That is the case when we want to
669 -- Detach a handler regardless of the Static status
670 -- of the current_Handler.
671 -- We don't check anything if Restoration is True, since we
672 -- may be detaching a static handler to restore a dynamic one.
674 if not Restoration
and then not Static
675 -- Tries to overwrite a static Interrupt Handler with a
678 and then (User_Handler
(Interrupt
).Static
680 -- The new handler is not specified as an
681 -- Interrupt Handler by a pragma.
683 or else not Is_Registered
(New_Handler
))
685 Raise_Exception
(Program_Error
'Identity,
686 "Trying to overwrite a static Interrupt Handler with a " &
690 -- The interrupt should no longer be ingnored if
691 -- it was ever ignored.
693 Ignored
(Interrupt
) := False;
695 -- Save the old handler
697 Old_Handler
:= User_Handler
(Interrupt
).H
;
701 User_Handler
(Interrupt
).H
:= New_Handler
;
703 if New_Handler
= null then
705 -- The null handler means we are detaching the handler.
707 User_Handler
(Interrupt
).Static
:= False;
710 User_Handler
(Interrupt
).Static
:= Static
;
713 -- Invoke a corresponding Server_Task if not yet created.
714 -- Place Task_ID info in Server_ID array.
716 if Server_ID
(Interrupt
) = Null_Task
then
717 Access_Hold
:= new Server_Task
(Interrupt
);
718 Server_ID
(Interrupt
) := To_System
(Access_Hold
.all'Identity);
720 POP
.Wakeup
(Server_ID
(Interrupt
), Interrupt_Server_Idle_Sleep
);
723 end Unprotected_Exchange_Handler
;
725 --------------------------------
726 -- Unprotected_Detach_Handler --
727 --------------------------------
729 procedure Unprotected_Detach_Handler
730 (Interrupt
: in Interrupt_ID
;
733 Old_Handler
: Parameterless_Handler
;
736 if User_Entry
(Interrupt
).T
/= Null_Task
then
737 -- In case we have an Interrupt Entry installed.
738 -- raise a program error. (propagate it to the caller).
740 Raise_Exception
(Program_Error
'Identity,
741 "An interrupt entry is already installed");
744 -- Note : Static = True will pass the following check. That is the
745 -- case when we want to detach a handler regardless of the static
746 -- status of the current_Handler.
748 if not Static
and then User_Handler
(Interrupt
).Static
then
749 -- Tries to detach a static Interrupt Handler.
750 -- raise a program error.
752 Raise_Exception
(Program_Error
'Identity,
753 "Trying to detach a static Interrupt Handler");
756 -- The interrupt should no longer be ignored if
757 -- it was ever ignored.
759 Ignored
(Interrupt
) := False;
761 Old_Handler
:= User_Handler
(Interrupt
).H
;
765 User_Handler
(Interrupt
).H
:= null;
766 User_Handler
(Interrupt
).Static
:= False;
767 IMOP
.Interrupt_Self_Process
(IMNG
.Interrupt_ID
(Interrupt
));
769 end Unprotected_Detach_Handler
;
771 -- Start of processing for Interrupt_Manager
774 -- By making this task independent of master, when the process
775 -- goes away, the Interrupt_Manager will terminate gracefully.
777 System
.Tasking
.Utilities
.Make_Independent
;
779 -- Environmen task gets its own interrupt mask, saves it,
780 -- and then masks all interrupts except the Keep_Unmasked set.
782 -- During rendezvous, the Interrupt_Manager receives the old
783 -- interrupt mask of the environment task, and sets its own
784 -- interrupt mask to that value.
786 -- The environment task will call the entry of Interrupt_Manager some
787 -- during elaboration of the body of this package.
789 accept Initialize
(Mask
: IMNG
.Interrupt_Mask
) do
793 -- Note: All tasks in RTS will have all the Reserve Interrupts
794 -- being masked (except the Interrupt_Manager) and Keep_Unmasked
795 -- unmasked when created.
797 -- Abort_Task_Interrupt is one of the Interrupt unmasked
798 -- in all tasks. We mask the Interrupt in this particular task
799 -- so that "sigwait" is possible to catch an explicitly sent
800 -- Abort_Task_Interrupt from the Server_Tasks.
802 -- This sigwaiting is needed so that we make sure a Server_Task is
803 -- out of its own sigwait state. This extra synchronization is
804 -- necessary to prevent following senarios.
806 -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to the
807 -- Server_Task then changes its own interrupt mask (OS level).
808 -- If an interrupt (corresponding to the Server_Task) arrives
809 -- in the nean time we have the Interrupt_Manager umnasked and
810 -- the Server_Task waiting on sigwait.
812 -- 2) For unbinding handler, we install a default action in the
813 -- Interrupt_Manager. POSIX.1c states that the result of using
814 -- "sigwait" and "sigaction" simaltaneously on the same interrupt
815 -- is undefined. Therefore, we need to be informed from the
816 -- Server_Task of the fact that the Server_Task is out of its
820 -- A block is needed to absorb Program_Error exception
823 Old_Handler
: Parameterless_Handler
;
827 accept Attach_Handler
828 (New_Handler
: in Parameterless_Handler
;
829 Interrupt
: in Interrupt_ID
;
831 Restoration
: in Boolean := False)
833 Unprotected_Exchange_Handler
834 (Old_Handler
, New_Handler
, Interrupt
, Static
, Restoration
);
837 or accept Exchange_Handler
838 (Old_Handler
: out Parameterless_Handler
;
839 New_Handler
: in Parameterless_Handler
;
840 Interrupt
: in Interrupt_ID
;
843 Unprotected_Exchange_Handler
844 (Old_Handler
, New_Handler
, Interrupt
, Static
);
845 end Exchange_Handler
;
847 or accept Detach_Handler
848 (Interrupt
: in Interrupt_ID
;
851 Unprotected_Detach_Handler
(Interrupt
, Static
);
854 or accept Bind_Interrupt_To_Entry
856 E
: Task_Entry_Index
;
857 Interrupt
: Interrupt_ID
)
859 -- if there is a binding already (either a procedure or an
860 -- entry), raise Program_Error (propagate it to the caller).
862 if User_Handler
(Interrupt
).H
/= null
863 or else User_Entry
(Interrupt
).T
/= Null_Task
865 Raise_Exception
(Program_Error
'Identity,
866 "A binding for this interrupt is already present");
869 -- The interrupt should no longer be ingnored if
870 -- it was ever ignored.
872 Ignored
(Interrupt
) := False;
873 User_Entry
(Interrupt
) := Entry_Assoc
' (T => T, E => E);
875 -- Indicate the attachment of Interrupt Entry in ATCB.
876 -- This is need so that when an Interrupt Entry task
877 -- terminates the binding can be cleaned.
878 -- The call to unbinding must be
879 -- make by the task before it terminates.
881 T.Interrupt_Entry := True;
883 -- Invoke a corresponding Server_Task if not yet created.
884 -- Place Task_ID info in Server_ID array.
886 if Server_ID (Interrupt) = Null_Task then
888 Access_Hold := new Server_Task (Interrupt);
889 Server_ID (Interrupt) :=
890 To_System (Access_Hold.all'Identity);
892 POP.Wakeup (Server_ID (Interrupt),
893 Interrupt_Server_Idle_Sleep);
895 end Bind_Interrupt_To_Entry;
897 or accept Detach_Interrupt_Entries (T : Task_ID)
899 for I in Interrupt_ID'Range loop
900 if not Is_Reserved (I) then
901 if User_Entry (I).T = T then
903 -- The interrupt should no longer be ignored if
904 -- it was ever ignored.
906 Ignored (I) := False;
907 User_Entry (I) := Entry_Assoc'
908 (T
=> Null_Task
, E
=> Null_Task_Entry
);
909 IMOP
.Interrupt_Self_Process
(IMNG
.Interrupt_ID
(I
));
914 -- Indicate in ATCB that no Interrupt Entries are attached.
916 T
.Interrupt_Entry
:= False;
917 end Detach_Interrupt_Entries
;
919 or accept Block_Interrupt
(Interrupt
: Interrupt_ID
) do
923 or accept Unblock_Interrupt
(Interrupt
: Interrupt_ID
) do
925 end Unblock_Interrupt
;
927 or accept Ignore_Interrupt
(Interrupt
: Interrupt_ID
) do
929 end Ignore_Interrupt
;
931 or accept Unignore_Interrupt
(Interrupt
: Interrupt_ID
) do
933 end Unignore_Interrupt
;
938 -- If there is a program error we just want to propagate it
939 -- to the caller and do not want to stop this task.
941 when Program_Error
=>
945 pragma Assert
(False);
949 end Interrupt_Manager
;
955 task body Server_Task
is
956 Self_ID
: Task_ID
:= Self
;
957 Tmp_Handler
: Parameterless_Handler
;
959 Tmp_Entry_Index
: Task_Entry_Index
;
960 Intwait_Mask
: aliased IMNG
.Interrupt_Mask
;
961 Ret_Interrupt
: IMNG
.Interrupt_ID
;
964 -- By making this task independent of master, when the process
965 -- goes away, the Server_Task will terminate gracefully.
967 System
.Tasking
.Utilities
.Make_Independent
;
969 -- Install default action in system level.
971 IMOP
.Install_Default_Action
(IMNG
.Interrupt_ID
(Interrupt
));
973 -- Set up the mask (also clears the event flag)
975 IMOP
.Empty_Interrupt_Mask
(Intwait_Mask
'Access);
976 IMOP
.Add_To_Interrupt_Mask
977 (Intwait_Mask
'Access, IMNG
.Interrupt_ID
(Interrupt
));
979 -- Remember the Interrupt_ID for Abort_Task.
981 PIO
.Set_Interrupt_ID
(IMNG
.Interrupt_ID
(Interrupt
), Self_ID
);
983 -- Note: All tasks in RTS will have all the Reserve Interrupts
984 -- being masked (except the Interrupt_Manager) and Keep_Unmasked
985 -- unmasked when created.
988 System
.Tasking
.Initialization
.Defer_Abort
(Self_ID
);
990 -- A Handler or an Entry is installed. At this point all tasks
991 -- mask for the Interrupt is masked. Catch the Interrupt using
994 -- This task may wake up from sigwait by receiving an interrupt
995 -- (Abort_Task_Interrupt) from the Interrupt_Manager for unbinding
996 -- a Procedure Handler or an Entry. Or it could be a wake up
997 -- from status change (Unblocked -> Blocked). If that is not
998 -- the case, we should exceute the attached Procedure or Entry.
1004 POP
.Write_Lock
(Self_ID
);
1006 if User_Handler
(Interrupt
).H
= null
1007 and then User_Entry
(Interrupt
).T
= Null_Task
1009 -- No Interrupt binding. If there is an interrupt,
1010 -- Interrupt_Manager will take default action.
1012 Self_ID
.Common
.State
:= Interrupt_Server_Idle_Sleep
;
1013 POP
.Sleep
(Self_ID
, Interrupt_Server_Idle_Sleep
);
1014 Self_ID
.Common
.State
:= Runnable
;
1017 Self_ID
.Common
.State
:= Interrupt_Server_Blocked_On_Event_Flag
;
1018 Ret_Interrupt
:= IMOP
.Interrupt_Wait
(Intwait_Mask
'Access);
1019 Self_ID
.Common
.State
:= Runnable
;
1021 if not (Self_ID
.Deferral_Level
= 0
1022 and then Self_ID
.Pending_ATC_Level
1023 < Self_ID
.ATC_Nesting_Level
)
1025 if User_Handler
(Interrupt
).H
/= null then
1026 Tmp_Handler
:= User_Handler
(Interrupt
).H
;
1028 -- RTS calls should not be made with self being locked.
1030 POP
.Unlock
(Self_ID
);
1037 POP
.Write_Lock
(Self_ID
);
1043 elsif User_Entry
(Interrupt
).T
/= Null_Task
then
1044 Tmp_ID
:= User_Entry
(Interrupt
).T
;
1045 Tmp_Entry_Index
:= User_Entry
(Interrupt
).E
;
1047 -- RTS calls should not be made with self being locked.
1049 POP
.Unlock
(Self_ID
);
1055 System
.Tasking
.Rendezvous
.Call_Simple
1056 (Tmp_ID
, Tmp_Entry_Index
, System
.Null_Address
);
1058 POP
.Write_Lock
(Self_ID
);
1067 POP
.Unlock
(Self_ID
);
1073 System
.Tasking
.Initialization
.Undefer_Abort
(Self_ID
);
1075 -- Undefer abort here to allow a window for this task
1076 -- to be aborted at the time of system shutdown.
1080 -------------------------------------
1081 -- Has_Interrupt_Or_Attach_Handler --
1082 -------------------------------------
1084 function Has_Interrupt_Or_Attach_Handler
1085 (Object
: access Dynamic_Interrupt_Protection
) return Boolean is
1088 end Has_Interrupt_Or_Attach_Handler
;
1094 procedure Finalize
(Object
: in out Static_Interrupt_Protection
) is
1096 -- ??? loop to be executed only when we're not doing library level
1097 -- finalization, since in this case all interrupt tasks are gone.
1098 if not Interrupt_Manager
'Terminated then
1099 for N
in reverse Object
.Previous_Handlers
'Range loop
1100 Interrupt_Manager
.Attach_Handler
1101 (New_Handler
=> Object
.Previous_Handlers
(N
).Handler
,
1102 Interrupt
=> Object
.Previous_Handlers
(N
).Interrupt
,
1103 Static
=> Object
.Previous_Handlers
(N
).Static
,
1104 Restoration
=> True);
1108 Tasking
.Protected_Objects
.Entries
.Finalize
1109 (Tasking
.Protected_Objects
.Entries
.Protection_Entries
(Object
));
1112 -------------------------------------
1113 -- Has_Interrupt_Or_Attach_Handler --
1114 -------------------------------------
1116 function Has_Interrupt_Or_Attach_Handler
1117 (Object
: access Static_Interrupt_Protection
)
1122 end Has_Interrupt_Or_Attach_Handler
;
1124 ----------------------
1125 -- Install_Handlers --
1126 ----------------------
1128 procedure Install_Handlers
1129 (Object
: access Static_Interrupt_Protection
;
1130 New_Handlers
: in New_Handler_Array
) is
1132 for N
in New_Handlers
'Range loop
1134 -- We need a lock around this ???
1136 Object
.Previous_Handlers
(N
).Interrupt
:= New_Handlers
(N
).Interrupt
;
1137 Object
.Previous_Handlers
(N
).Static
:= User_Handler
1138 (New_Handlers
(N
).Interrupt
).Static
;
1140 -- We call Exchange_Handler and not directly Interrupt_Manager.
1141 -- Exchange_Handler so we get the Is_Reserved check.
1144 (Old_Handler
=> Object
.Previous_Handlers
(N
).Handler
,
1145 New_Handler
=> New_Handlers
(N
).Handler
,
1146 Interrupt
=> New_Handlers
(N
).Interrupt
,
1149 end Install_Handlers
;
1151 -- Elaboration code for package System.Interrupts
1154 -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent.
1156 Interrupt_Manager_ID
:= To_System
(Interrupt_Manager
'Identity);
1158 -- During the elaboration of this package body we want RTS to
1159 -- inherit the interrupt mask from the Environment Task.
1161 -- The Environment Task should have gotten its mask from
1162 -- the enclosing process during the RTS start up. (See
1163 -- in s-inmaop.adb). Pass the Interrupt_Mask of the Environment
1164 -- task to the Interrupt_Manager.
1166 -- Note : At this point we know that all tasks (including
1167 -- RTS internal servers) are masked for non-reserved signals
1168 -- (see s-taprop.adb). Only the Interrupt_Manager will have
1169 -- masks set up differently inheriting the original Environment
1172 Interrupt_Manager
.Initialize
(IMOP
.Environment_Mask
);
1173 end System
.Interrupts
;