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 ------------------------------------------------------------------------------
34 -- This is an OpenVMS/Alpha version of this package
38 -- Once we associate a Server_Task with an interrupt, the task never
39 -- goes away, and we never remove the association.
41 -- There is no more than one interrupt per Server_Task and no more than
42 -- one Server_Task per interrupt.
44 -- Within this package, the lock L is used to protect the various status
45 -- tables. If there is a Server_Task associated with an interrupt, we use
46 -- the per-task lock of the Server_Task instead so that we protect the
47 -- status between Interrupt_Manager and Server_Task. Protection among
48 -- service requests are done using User Request to Interrupt_Manager
51 with Ada
.Task_Identification
;
52 -- used for Task_Id type
55 -- used for Raise_Exception
57 with System
.Task_Primitives
;
61 with System
.Interrupt_Management
;
65 -- Abort_Task_Interrupt
67 with System
.Interrupt_Management
.Operations
;
68 -- used for Thread_Block_Interrupt
69 -- Thread_Unblock_Interrupt
70 -- Install_Default_Action
71 -- Install_Ignore_Action
72 -- Copy_Interrupt_Mask
74 -- Empty_Interrupt_Mask
75 -- Fill_Interrupt_Mask
76 -- Add_To_Interrupt_Mask
77 -- Delete_From_Interrupt_Mask
79 -- Interrupt_Self_Process
84 pragma Elaborate_All
(System
.Interrupt_Management
.Operations
);
86 with System
.Task_Primitives
.Operations
;
87 -- used for Write_Lock
94 with System
.Task_Primitives
.Interrupt_Operations
;
95 -- used for Set_Interrupt_ID
97 with System
.Storage_Elements
;
98 -- used for To_Address
102 with System
.Tasking
.Utilities
;
103 -- used for Make_Independent
105 with System
.Tasking
.Rendezvous
;
106 -- used for Call_Simple
107 pragma Elaborate_All
(System
.Tasking
.Rendezvous
);
109 with System
.Tasking
.Initialization
;
110 -- used for Defer_Abort
113 with System
.Parameters
;
114 -- used for Single_Lock
116 with Unchecked_Conversion
;
118 package body System
.Interrupts
is
121 use System
.Parameters
;
124 package POP
renames System
.Task_Primitives
.Operations
;
125 package PIO
renames System
.Task_Primitives
.Interrupt_Operations
;
126 package IMNG
renames System
.Interrupt_Management
;
127 package IMOP
renames System
.Interrupt_Management
.Operations
;
129 function To_System
is new Unchecked_Conversion
130 (Ada
.Task_Identification
.Task_Id
, Task_Id
);
136 -- WARNING: System.Tasking.Stages performs calls to this task with
137 -- low-level constructs. Do not change this spec without synchronizing it.
139 task Interrupt_Manager
is
140 entry Detach_Interrupt_Entries
(T
: Task_Id
);
142 entry Initialize
(Mask
: IMNG
.Interrupt_Mask
);
145 (New_Handler
: Parameterless_Handler
;
146 Interrupt
: Interrupt_ID
;
148 Restoration
: Boolean := False);
150 entry Exchange_Handler
151 (Old_Handler
: out Parameterless_Handler
;
152 New_Handler
: Parameterless_Handler
;
153 Interrupt
: Interrupt_ID
;
157 (Interrupt
: Interrupt_ID
;
160 entry Bind_Interrupt_To_Entry
162 E
: Task_Entry_Index
;
163 Interrupt
: Interrupt_ID
);
165 entry Block_Interrupt
(Interrupt
: Interrupt_ID
);
167 entry Unblock_Interrupt
(Interrupt
: Interrupt_ID
);
169 entry Ignore_Interrupt
(Interrupt
: Interrupt_ID
);
171 entry Unignore_Interrupt
(Interrupt
: Interrupt_ID
);
173 pragma Interrupt_Priority
(System
.Interrupt_Priority
'Last);
174 end Interrupt_Manager
;
176 task type Server_Task
(Interrupt
: Interrupt_ID
) is
177 pragma Priority
(System
.Interrupt_Priority
'Last);
178 -- Note: the above pragma Priority is strictly speaking improper since
179 -- it is outside the range of allowed priorities, but the compiler
180 -- treats system units specially and does not apply this range checking
181 -- rule to system units.
185 type Server_Task_Access
is access Server_Task
;
187 -------------------------------
188 -- Local Types and Variables --
189 -------------------------------
191 type Entry_Assoc
is record
193 E
: Task_Entry_Index
;
196 type Handler_Assoc
is record
197 H
: Parameterless_Handler
;
198 Static
: Boolean; -- Indicates static binding;
201 User_Handler
: array (Interrupt_ID
'Range) of Handler_Assoc
:=
202 (others => (null, Static
=> False));
203 pragma Volatile_Components
(User_Handler
);
204 -- Holds the protected procedure handler (if any) and its Static
205 -- information for each interrupt. A handler is a Static one if it is
206 -- specified through the pragma Attach_Handler. Attach_Handler. Otherwise,
209 User_Entry
: array (Interrupt_ID
'Range) of Entry_Assoc
:=
210 (others => (T
=> Null_Task
, E
=> Null_Task_Entry
));
211 pragma Volatile_Components
(User_Entry
);
212 -- Holds the task and entry index (if any) for each interrupt
214 Blocked
: constant array (Interrupt_ID
'Range) of Boolean :=
216 -- ??? pragma Volatile_Components (Blocked);
217 -- True iff the corresponding interrupt is blocked in the process level
219 Ignored
: array (Interrupt_ID
'Range) of Boolean := (others => False);
220 pragma Volatile_Components
(Ignored
);
221 -- True iff the corresponding interrupt is blocked in the process level
223 Last_Unblocker
: constant array (Interrupt_ID
'Range) of Task_Id
:=
224 (others => Null_Task
);
225 -- ??? pragma Volatile_Components (Last_Unblocker);
226 -- Holds the ID of the last Task which Unblocked this Interrupt.
227 -- It contains Null_Task if no tasks have ever requested the
228 -- Unblocking operation or the Interrupt is currently Blocked.
230 Server_ID
: array (Interrupt_ID
'Range) of Task_Id
:=
231 (others => Null_Task
);
232 pragma Atomic_Components
(Server_ID
);
233 -- Holds the Task_Id of the Server_Task for each interrupt. Task_Id is
234 -- needed to accomplish locking per Interrupt base. Also is needed to
235 -- decide whether to create a new Server_Task.
237 -- Type and Head, Tail of the list containing Registered Interrupt
238 -- Handlers. These definitions are used to register the handlers specified
239 -- by the pragma Interrupt_Handler.
241 type Registered_Handler
;
242 type R_Link
is access all Registered_Handler
;
244 type Registered_Handler
is record
245 H
: System
.Address
:= System
.Null_Address
;
246 Next
: R_Link
:= null;
249 Registered_Handler_Head
: R_Link
:= null;
250 Registered_Handler_Tail
: R_Link
:= null;
252 Access_Hold
: Server_Task_Access
;
253 -- variable used to allocate Server_Task using "new".
255 -----------------------
256 -- Local Subprograms --
257 -----------------------
259 function Is_Registered
(Handler
: Parameterless_Handler
) return Boolean;
260 -- See if the Handler has been "pragma"ed using Interrupt_Handler.
261 -- Always consider a null handler as registered.
263 --------------------------------
264 -- Register_Interrupt_Handler --
265 --------------------------------
267 procedure Register_Interrupt_Handler
(Handler_Addr
: System
.Address
) is
268 New_Node_Ptr
: R_Link
;
270 -- This routine registers the Handler as usable for Dynamic
271 -- Interrupt Handler. Routines attaching and detaching Handler
272 -- dynamically should first consult if the Handler is rgistered.
273 -- A Program Error should be raised if it is not registered.
275 -- The pragma Interrupt_Handler can only appear in the library
276 -- level PO definition and instantiation. Therefore, we do not need
277 -- to implement Unregistering operation. Neither we need to
278 -- protect the queue structure using a Lock.
280 pragma Assert
(Handler_Addr
/= System
.Null_Address
);
282 New_Node_Ptr
:= new Registered_Handler
;
283 New_Node_Ptr
.H
:= Handler_Addr
;
285 if Registered_Handler_Head
= null then
286 Registered_Handler_Head
:= New_Node_Ptr
;
287 Registered_Handler_Tail
:= New_Node_Ptr
;
290 Registered_Handler_Tail
.Next
:= New_Node_Ptr
;
291 Registered_Handler_Tail
:= New_Node_Ptr
;
293 end Register_Interrupt_Handler
;
299 function Is_Registered
(Handler
: Parameterless_Handler
) return Boolean is
300 type Fat_Ptr
is record
301 Object_Addr
: System
.Address
;
302 Handler_Addr
: System
.Address
;
305 function To_Fat_Ptr
is new Unchecked_Conversion
306 (Parameterless_Handler
, Fat_Ptr
);
312 if Handler
= null then
316 Fat
:= To_Fat_Ptr
(Handler
);
318 Ptr
:= Registered_Handler_Head
;
320 while Ptr
/= null loop
321 if Ptr
.H
= Fat
.Handler_Addr
then
335 function Is_Reserved
(Interrupt
: Interrupt_ID
) return Boolean is
337 return IMNG
.Reserve
(IMNG
.Interrupt_ID
(Interrupt
));
340 -----------------------
341 -- Is_Entry_Attached --
342 -----------------------
344 function Is_Entry_Attached
(Interrupt
: Interrupt_ID
) return Boolean is
346 if Is_Reserved
(Interrupt
) then
347 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
348 Interrupt_ID
'Image (Interrupt
) & " is reserved");
351 return User_Entry
(Interrupt
).T
/= Null_Task
;
352 end Is_Entry_Attached
;
354 -------------------------
355 -- Is_Handler_Attached --
356 -------------------------
358 function Is_Handler_Attached
(Interrupt
: Interrupt_ID
) return Boolean is
360 if Is_Reserved
(Interrupt
) then
361 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
362 Interrupt_ID
'Image (Interrupt
) & " is reserved");
365 return User_Handler
(Interrupt
).H
/= null;
366 end Is_Handler_Attached
;
372 function Is_Blocked
(Interrupt
: Interrupt_ID
) return Boolean is
374 if Is_Reserved
(Interrupt
) then
375 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
376 Interrupt_ID
'Image (Interrupt
) & " is reserved");
379 return Blocked
(Interrupt
);
386 function Is_Ignored
(Interrupt
: Interrupt_ID
) return Boolean is
388 if Is_Reserved
(Interrupt
) then
389 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
390 Interrupt_ID
'Image (Interrupt
) & " is reserved");
393 return Ignored
(Interrupt
);
396 ---------------------
397 -- Current_Handler --
398 ---------------------
400 function Current_Handler
401 (Interrupt
: Interrupt_ID
) return Parameterless_Handler
404 if Is_Reserved
(Interrupt
) then
405 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
406 Interrupt_ID
'Image (Interrupt
) & " is reserved");
409 -- ??? Since Parameterless_Handler is not Atomic, the current
410 -- implementation is wrong. We need a new service in Interrupt_Manager
411 -- to ensure atomicity.
413 return User_Handler
(Interrupt
).H
;
420 -- Calling this procedure with New_Handler = null and Static = True
421 -- means we want to detach the current handler regardless of the
422 -- previous handler's binding status (ie. do not care if it is a
423 -- dynamic or static handler).
425 -- This option is needed so that during the finalization of a PO, we
426 -- can detach handlers attached through pragma Attach_Handler.
428 procedure Attach_Handler
429 (New_Handler
: Parameterless_Handler
;
430 Interrupt
: Interrupt_ID
;
431 Static
: Boolean := False) is
433 if Is_Reserved
(Interrupt
) then
434 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
435 Interrupt_ID
'Image (Interrupt
) & " is reserved");
438 Interrupt_Manager
.Attach_Handler
(New_Handler
, Interrupt
, Static
);
442 ----------------------
443 -- Exchange_Handler --
444 ----------------------
446 -- Calling this procedure with New_Handler = null and Static = True means
447 -- we want to detach the current handler regardless of the previous
448 -- handler's binding status (ie. do not care if it is dynamic or static
451 -- This option is needed so that during the finalization of a PO, we can
452 -- detach handlers attached through pragma Attach_Handler.
454 procedure Exchange_Handler
455 (Old_Handler
: out Parameterless_Handler
;
456 New_Handler
: Parameterless_Handler
;
457 Interrupt
: Interrupt_ID
;
458 Static
: Boolean := False)
461 if Is_Reserved
(Interrupt
) then
462 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
463 Interrupt_ID
'Image (Interrupt
) & " is reserved");
466 Interrupt_Manager
.Exchange_Handler
467 (Old_Handler
, New_Handler
, Interrupt
, Static
);
469 end Exchange_Handler
;
475 -- Calling this procedure with Static = True means we want to Detach the
476 -- current handler regardless of the previous handler's binding status
477 -- (i.e. do not care if it is a dynamic or static handler).
479 -- This option is needed so that during the finalization of a PO, we can
480 -- detach handlers attached through pragma Attach_Handler.
482 procedure Detach_Handler
483 (Interrupt
: Interrupt_ID
;
484 Static
: Boolean := False)
487 if Is_Reserved
(Interrupt
) then
488 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
489 Interrupt_ID
'Image (Interrupt
) & " is reserved");
492 Interrupt_Manager
.Detach_Handler
(Interrupt
, Static
);
499 function Reference
(Interrupt
: Interrupt_ID
) return System
.Address
is
501 if Is_Reserved
(Interrupt
) then
502 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
503 Interrupt_ID
'Image (Interrupt
) & " is reserved");
506 return Storage_Elements
.To_Address
507 (Storage_Elements
.Integer_Address
(Interrupt
));
510 -----------------------------
511 -- Bind_Interrupt_To_Entry --
512 -----------------------------
514 -- This procedure raises a Program_Error if it tries to
515 -- bind an interrupt to which an Entry or a Procedure is
518 procedure Bind_Interrupt_To_Entry
520 E
: Task_Entry_Index
;
521 Int_Ref
: System
.Address
)
523 Interrupt
: constant Interrupt_ID
:=
524 Interrupt_ID
(Storage_Elements
.To_Integer
(Int_Ref
));
527 if Is_Reserved
(Interrupt
) then
528 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
529 Interrupt_ID
'Image (Interrupt
) & " is reserved");
532 Interrupt_Manager
.Bind_Interrupt_To_Entry
(T
, E
, Interrupt
);
534 end Bind_Interrupt_To_Entry
;
536 ------------------------------
537 -- Detach_Interrupt_Entries --
538 ------------------------------
540 procedure Detach_Interrupt_Entries
(T
: Task_Id
) is
542 Interrupt_Manager
.Detach_Interrupt_Entries
(T
);
543 end Detach_Interrupt_Entries
;
545 ---------------------
546 -- Block_Interrupt --
547 ---------------------
549 procedure Block_Interrupt
(Interrupt
: Interrupt_ID
) is
551 if Is_Reserved
(Interrupt
) then
552 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
553 Interrupt_ID
'Image (Interrupt
) & " is reserved");
556 Interrupt_Manager
.Block_Interrupt
(Interrupt
);
559 -----------------------
560 -- Unblock_Interrupt --
561 -----------------------
563 procedure Unblock_Interrupt
(Interrupt
: Interrupt_ID
) is
565 if Is_Reserved
(Interrupt
) then
566 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
567 Interrupt_ID
'Image (Interrupt
) & " is reserved");
570 Interrupt_Manager
.Unblock_Interrupt
(Interrupt
);
571 end Unblock_Interrupt
;
577 function Unblocked_By
578 (Interrupt
: Interrupt_ID
) return System
.Tasking
.Task_Id
is
580 if Is_Reserved
(Interrupt
) then
581 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
582 Interrupt_ID
'Image (Interrupt
) & " is reserved");
585 return Last_Unblocker
(Interrupt
);
588 ----------------------
589 -- Ignore_Interrupt --
590 ----------------------
592 procedure Ignore_Interrupt
(Interrupt
: Interrupt_ID
) is
594 if Is_Reserved
(Interrupt
) then
595 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
596 Interrupt_ID
'Image (Interrupt
) & " is reserved");
599 Interrupt_Manager
.Ignore_Interrupt
(Interrupt
);
600 end Ignore_Interrupt
;
602 ------------------------
603 -- Unignore_Interrupt --
604 ------------------------
606 procedure Unignore_Interrupt
(Interrupt
: Interrupt_ID
) is
608 if Is_Reserved
(Interrupt
) then
609 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
610 Interrupt_ID
'Image (Interrupt
) & " is reserved");
613 Interrupt_Manager
.Unignore_Interrupt
(Interrupt
);
614 end Unignore_Interrupt
;
616 -----------------------
617 -- Interrupt_Manager --
618 -----------------------
620 task body Interrupt_Manager
is
626 procedure Unprotected_Exchange_Handler
627 (Old_Handler
: out Parameterless_Handler
;
628 New_Handler
: Parameterless_Handler
;
629 Interrupt
: Interrupt_ID
;
631 Restoration
: Boolean := False);
633 procedure Unprotected_Detach_Handler
634 (Interrupt
: Interrupt_ID
;
637 ----------------------------------
638 -- Unprotected_Exchange_Handler --
639 ----------------------------------
641 procedure Unprotected_Exchange_Handler
642 (Old_Handler
: out Parameterless_Handler
;
643 New_Handler
: Parameterless_Handler
;
644 Interrupt
: Interrupt_ID
;
646 Restoration
: Boolean := False)
649 if User_Entry
(Interrupt
).T
/= Null_Task
then
650 -- In case we have an Interrupt Entry already installed.
651 -- raise a program error. (propagate it to the caller).
653 Raise_Exception
(Program_Error
'Identity,
654 "An interrupt is already installed");
657 -- Note : A null handler with Static = True will
658 -- pass the following check. That is the case when we want to
659 -- Detach a handler regardless of the Static status
660 -- of the current_Handler.
661 -- We don't check anything if Restoration is True, since we
662 -- may be detaching a static handler to restore a dynamic one.
664 if not Restoration
and then not Static
665 -- Tries to overwrite a static Interrupt Handler with a
668 and then (User_Handler
(Interrupt
).Static
670 -- The new handler is not specified as an
671 -- Interrupt Handler by a pragma.
673 or else not Is_Registered
(New_Handler
))
675 Raise_Exception
(Program_Error
'Identity,
676 "Trying to overwrite a static Interrupt Handler with a " &
680 -- The interrupt should no longer be ingnored if
681 -- it was ever ignored.
683 Ignored
(Interrupt
) := False;
685 -- Save the old handler
687 Old_Handler
:= User_Handler
(Interrupt
).H
;
691 User_Handler
(Interrupt
).H
:= New_Handler
;
693 if New_Handler
= null then
695 -- The null handler means we are detaching the handler.
697 User_Handler
(Interrupt
).Static
:= False;
700 User_Handler
(Interrupt
).Static
:= Static
;
703 -- Invoke a corresponding Server_Task if not yet created.
704 -- Place Task_Id info in Server_ID array.
706 if Server_ID
(Interrupt
) = Null_Task
then
707 Access_Hold
:= new Server_Task
(Interrupt
);
708 Server_ID
(Interrupt
) := To_System
(Access_Hold
.all'Identity);
710 POP
.Wakeup
(Server_ID
(Interrupt
), Interrupt_Server_Idle_Sleep
);
713 end Unprotected_Exchange_Handler
;
715 --------------------------------
716 -- Unprotected_Detach_Handler --
717 --------------------------------
719 procedure Unprotected_Detach_Handler
720 (Interrupt
: Interrupt_ID
;
724 if User_Entry
(Interrupt
).T
/= Null_Task
then
725 -- In case we have an Interrupt Entry installed.
726 -- raise a program error. (propagate it to the caller).
728 Raise_Exception
(Program_Error
'Identity,
729 "An interrupt entry is already installed");
732 -- Note : Static = True will pass the following check. That is the
733 -- case when we want to detach a handler regardless of the static
734 -- status of the current_Handler.
736 if not Static
and then User_Handler
(Interrupt
).Static
then
737 -- Tries to detach a static Interrupt Handler.
738 -- raise a program error.
740 Raise_Exception
(Program_Error
'Identity,
741 "Trying to detach a static Interrupt Handler");
744 -- The interrupt should no longer be ignored if
745 -- it was ever ignored.
747 Ignored
(Interrupt
) := False;
751 User_Handler
(Interrupt
).H
:= null;
752 User_Handler
(Interrupt
).Static
:= False;
753 IMOP
.Interrupt_Self_Process
(IMNG
.Interrupt_ID
(Interrupt
));
755 end Unprotected_Detach_Handler
;
757 -- Start of processing for Interrupt_Manager
760 -- By making this task independent of master, when the process
761 -- goes away, the Interrupt_Manager will terminate gracefully.
763 System
.Tasking
.Utilities
.Make_Independent
;
765 -- Environmen task gets its own interrupt mask, saves it,
766 -- and then masks all interrupts except the Keep_Unmasked set.
768 -- During rendezvous, the Interrupt_Manager receives the old
769 -- interrupt mask of the environment task, and sets its own
770 -- interrupt mask to that value.
772 -- The environment task will call the entry of Interrupt_Manager some
773 -- during elaboration of the body of this package.
775 accept Initialize
(Mask
: IMNG
.Interrupt_Mask
) do
776 pragma Warnings
(Off
, Mask
);
780 -- Note: All tasks in RTS will have all the Reserve Interrupts
781 -- being masked (except the Interrupt_Manager) and Keep_Unmasked
782 -- unmasked when created.
784 -- Abort_Task_Interrupt is one of the Interrupt unmasked
785 -- in all tasks. We mask the Interrupt in this particular task
786 -- so that "sigwait" is possible to catch an explicitely sent
787 -- Abort_Task_Interrupt from the Server_Tasks.
789 -- This sigwaiting is needed so that we make sure a Server_Task is
790 -- out of its own sigwait state. This extra synchronization is
791 -- necessary to prevent following senarios.
793 -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to the
794 -- Server_Task then changes its own interrupt mask (OS level).
795 -- If an interrupt (corresponding to the Server_Task) arrives
796 -- in the nean time we have the Interrupt_Manager umnasked and
797 -- the Server_Task waiting on sigwait.
799 -- 2) For unbinding handler, we install a default action in the
800 -- Interrupt_Manager. POSIX.1c states that the result of using
801 -- "sigwait" and "sigaction" simaltaneously on the same interrupt
802 -- is undefined. Therefore, we need to be informed from the
803 -- Server_Task of the fact that the Server_Task is out of its
807 -- A block is needed to absorb Program_Error exception
810 Old_Handler
: Parameterless_Handler
;
814 accept Attach_Handler
815 (New_Handler
: Parameterless_Handler
;
816 Interrupt
: Interrupt_ID
;
818 Restoration
: Boolean := False)
820 Unprotected_Exchange_Handler
821 (Old_Handler
, New_Handler
, Interrupt
, Static
, Restoration
);
824 or accept Exchange_Handler
825 (Old_Handler
: out Parameterless_Handler
;
826 New_Handler
: Parameterless_Handler
;
827 Interrupt
: Interrupt_ID
;
830 Unprotected_Exchange_Handler
831 (Old_Handler
, New_Handler
, Interrupt
, Static
);
832 end Exchange_Handler
;
834 or accept Detach_Handler
835 (Interrupt
: Interrupt_ID
;
838 Unprotected_Detach_Handler
(Interrupt
, Static
);
841 or accept Bind_Interrupt_To_Entry
843 E
: Task_Entry_Index
;
844 Interrupt
: Interrupt_ID
)
846 -- if there is a binding already (either a procedure or an
847 -- entry), raise Program_Error (propagate it to the caller).
849 if User_Handler
(Interrupt
).H
/= null
850 or else User_Entry
(Interrupt
).T
/= Null_Task
852 Raise_Exception
(Program_Error
'Identity,
853 "A binding for this interrupt is already present");
856 -- The interrupt should no longer be ingnored if
857 -- it was ever ignored.
859 Ignored
(Interrupt
) := False;
860 User_Entry
(Interrupt
) := Entry_Assoc
'(T => T, E => E);
862 -- Indicate the attachment of Interrupt Entry in ATCB.
863 -- This is need so that when an Interrupt Entry task
864 -- terminates the binding can be cleaned.
865 -- The call to unbinding must be
866 -- make by the task before it terminates.
868 T.Interrupt_Entry := True;
870 -- Invoke a corresponding Server_Task if not yet created.
871 -- Place Task_Id info in Server_ID array.
873 if Server_ID (Interrupt) = Null_Task then
875 Access_Hold := new Server_Task (Interrupt);
876 Server_ID (Interrupt) :=
877 To_System (Access_Hold.all'Identity);
879 POP.Wakeup (Server_ID (Interrupt),
880 Interrupt_Server_Idle_Sleep);
882 end Bind_Interrupt_To_Entry;
884 or accept Detach_Interrupt_Entries (T : Task_Id)
886 for J in Interrupt_ID'Range loop
887 if not Is_Reserved (J) then
888 if User_Entry (J).T = T then
890 -- The interrupt should no longer be ignored if
891 -- it was ever ignored.
893 Ignored (J) := False;
895 Entry_Assoc'(T
=> Null_Task
, E
=> Null_Task_Entry
);
896 IMOP
.Interrupt_Self_Process
(IMNG
.Interrupt_ID
(J
));
901 -- Indicate in ATCB that no Interrupt Entries are attached.
903 T
.Interrupt_Entry
:= False;
904 end Detach_Interrupt_Entries
;
906 or accept Block_Interrupt
(Interrupt
: Interrupt_ID
) do
907 pragma Warnings
(Off
, Interrupt
);
911 or accept Unblock_Interrupt
(Interrupt
: Interrupt_ID
) do
912 pragma Warnings
(Off
, Interrupt
);
914 end Unblock_Interrupt
;
916 or accept Ignore_Interrupt
(Interrupt
: Interrupt_ID
) do
917 pragma Warnings
(Off
, Interrupt
);
919 end Ignore_Interrupt
;
921 or accept Unignore_Interrupt
(Interrupt
: Interrupt_ID
) do
922 pragma Warnings
(Off
, Interrupt
);
924 end Unignore_Interrupt
;
929 -- If there is a program error we just want to propagate it
930 -- to the caller and do not want to stop this task.
932 when Program_Error
=>
936 pragma Assert
(False);
940 end Interrupt_Manager
;
946 task body Server_Task
is
947 Self_ID
: constant Task_Id
:= Self
;
948 Tmp_Handler
: Parameterless_Handler
;
950 Tmp_Entry_Index
: Task_Entry_Index
;
951 Intwait_Mask
: aliased IMNG
.Interrupt_Mask
;
954 -- By making this task independent of master, when the process
955 -- goes away, the Server_Task will terminate gracefully.
957 System
.Tasking
.Utilities
.Make_Independent
;
959 -- Install default action in system level.
961 IMOP
.Install_Default_Action
(IMNG
.Interrupt_ID
(Interrupt
));
963 -- Set up the mask (also clears the event flag)
965 IMOP
.Empty_Interrupt_Mask
(Intwait_Mask
'Access);
966 IMOP
.Add_To_Interrupt_Mask
967 (Intwait_Mask
'Access, IMNG
.Interrupt_ID
(Interrupt
));
969 -- Remember the Interrupt_ID for Abort_Task.
971 PIO
.Set_Interrupt_ID
(IMNG
.Interrupt_ID
(Interrupt
), Self_ID
);
973 -- Note: All tasks in RTS will have all the Reserve Interrupts
974 -- being masked (except the Interrupt_Manager) and Keep_Unmasked
975 -- unmasked when created.
978 System
.Tasking
.Initialization
.Defer_Abort
(Self_ID
);
980 -- A Handler or an Entry is installed. At this point all tasks
981 -- mask for the Interrupt is masked. Catch the Interrupt using
984 -- This task may wake up from sigwait by receiving an interrupt
985 -- (Abort_Task_Interrupt) from the Interrupt_Manager for unbinding
986 -- a Procedure Handler or an Entry. Or it could be a wake up
987 -- from status change (Unblocked -> Blocked). If that is not
988 -- the case, we should exceute the attached Procedure or Entry.
994 POP
.Write_Lock
(Self_ID
);
996 if User_Handler
(Interrupt
).H
= null
997 and then User_Entry
(Interrupt
).T
= Null_Task
999 -- No Interrupt binding. If there is an interrupt,
1000 -- Interrupt_Manager will take default action.
1002 Self_ID
.Common
.State
:= Interrupt_Server_Idle_Sleep
;
1003 POP
.Sleep
(Self_ID
, Interrupt_Server_Idle_Sleep
);
1004 Self_ID
.Common
.State
:= Runnable
;
1007 Self_ID
.Common
.State
:= Interrupt_Server_Blocked_On_Event_Flag
;
1008 Self_ID
.Common
.State
:= Runnable
;
1010 if not (Self_ID
.Deferral_Level
= 0
1011 and then Self_ID
.Pending_ATC_Level
1012 < Self_ID
.ATC_Nesting_Level
)
1014 if User_Handler
(Interrupt
).H
/= null then
1015 Tmp_Handler
:= User_Handler
(Interrupt
).H
;
1017 -- RTS calls should not be made with self being locked.
1019 POP
.Unlock
(Self_ID
);
1031 POP
.Write_Lock
(Self_ID
);
1033 elsif User_Entry
(Interrupt
).T
/= Null_Task
then
1034 Tmp_ID
:= User_Entry
(Interrupt
).T
;
1035 Tmp_Entry_Index
:= User_Entry
(Interrupt
).E
;
1037 -- RTS calls should not be made with self being locked.
1039 POP
.Unlock
(Self_ID
);
1045 System
.Tasking
.Rendezvous
.Call_Simple
1046 (Tmp_ID
, Tmp_Entry_Index
, System
.Null_Address
);
1052 POP
.Write_Lock
(Self_ID
);
1057 POP
.Unlock
(Self_ID
);
1063 System
.Tasking
.Initialization
.Undefer_Abort
(Self_ID
);
1065 -- Undefer abort here to allow a window for this task
1066 -- to be aborted at the time of system shutdown.
1070 -------------------------------------
1071 -- Has_Interrupt_Or_Attach_Handler --
1072 -------------------------------------
1074 function Has_Interrupt_Or_Attach_Handler
1075 (Object
: access Dynamic_Interrupt_Protection
) return Boolean
1077 pragma Warnings
(Off
, Object
);
1081 end Has_Interrupt_Or_Attach_Handler
;
1087 procedure Finalize
(Object
: in out Static_Interrupt_Protection
) is
1089 -- ??? loop to be executed only when we're not doing library level
1090 -- finalization, since in this case all interrupt tasks are gone.
1092 if not Interrupt_Manager
'Terminated then
1093 for N
in reverse Object
.Previous_Handlers
'Range loop
1094 Interrupt_Manager
.Attach_Handler
1095 (New_Handler
=> Object
.Previous_Handlers
(N
).Handler
,
1096 Interrupt
=> Object
.Previous_Handlers
(N
).Interrupt
,
1097 Static
=> Object
.Previous_Handlers
(N
).Static
,
1098 Restoration
=> True);
1102 Tasking
.Protected_Objects
.Entries
.Finalize
1103 (Tasking
.Protected_Objects
.Entries
.Protection_Entries
(Object
));
1106 -------------------------------------
1107 -- Has_Interrupt_Or_Attach_Handler --
1108 -------------------------------------
1110 function Has_Interrupt_Or_Attach_Handler
1111 (Object
: access Static_Interrupt_Protection
) return Boolean
1113 pragma Warnings
(Off
, Object
);
1116 end Has_Interrupt_Or_Attach_Handler
;
1118 ----------------------
1119 -- Install_Handlers --
1120 ----------------------
1122 procedure Install_Handlers
1123 (Object
: access Static_Interrupt_Protection
;
1124 New_Handlers
: New_Handler_Array
)
1127 for N
in New_Handlers
'Range loop
1129 -- We need a lock around this ???
1131 Object
.Previous_Handlers
(N
).Interrupt
:= New_Handlers
(N
).Interrupt
;
1132 Object
.Previous_Handlers
(N
).Static
:= User_Handler
1133 (New_Handlers
(N
).Interrupt
).Static
;
1135 -- We call Exchange_Handler and not directly Interrupt_Manager.
1136 -- Exchange_Handler so we get the Is_Reserved check.
1139 (Old_Handler
=> Object
.Previous_Handlers
(N
).Handler
,
1140 New_Handler
=> New_Handlers
(N
).Handler
,
1141 Interrupt
=> New_Handlers
(N
).Interrupt
,
1144 end Install_Handlers
;
1146 -- Elaboration code for package System.Interrupts
1150 -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent.
1152 Interrupt_Manager_ID
:= To_System
(Interrupt_Manager
'Identity);
1154 -- During the elaboration of this package body we want RTS to inherit the
1155 -- interrupt mask from the Environment Task.
1157 -- The Environment Task should have gotten its mask from the enclosing
1158 -- process during the RTS start up. (See in s-inmaop.adb). Pass the
1159 -- Interrupt_Mask of the Environment task to the Interrupt_Manager.
1161 -- Note : At this point we know that all tasks (including RTS internal
1162 -- servers) are masked for non-reserved signals (see s-taprop.adb). Only
1163 -- the Interrupt_Manager will have masks set up differently inheriting the
1164 -- original Environment Task's mask.
1166 Interrupt_Manager
.Initialize
(IMOP
.Environment_Mask
);
1167 end System
.Interrupts
;