1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- S Y S T E M . I N T E R R U P T S --
9 -- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
11 -- GNARL is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNARL; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNARL was developed by the GNARL team at Florida State University. --
30 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
32 ------------------------------------------------------------------------------
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 with Ada
.Unchecked_Conversion
;
54 with System
.Task_Primitives
;
55 with System
.Interrupt_Management
;
57 with System
.Interrupt_Management
.Operations
;
58 pragma Elaborate_All
(System
.Interrupt_Management
.Operations
);
60 with System
.Task_Primitives
.Operations
;
61 with System
.Task_Primitives
.Interrupt_Operations
;
62 with System
.Storage_Elements
;
63 with System
.Tasking
.Utilities
;
65 with System
.Tasking
.Rendezvous
;
66 pragma Elaborate_All
(System
.Tasking
.Rendezvous
);
68 with System
.Tasking
.Initialization
;
69 with System
.Parameters
;
71 package body System
.Interrupts
is
74 use System
.Parameters
;
76 package POP
renames System
.Task_Primitives
.Operations
;
77 package PIO
renames System
.Task_Primitives
.Interrupt_Operations
;
78 package IMNG
renames System
.Interrupt_Management
;
79 package IMOP
renames System
.Interrupt_Management
.Operations
;
81 function To_System
is new Ada
.Unchecked_Conversion
82 (Ada
.Task_Identification
.Task_Id
, Task_Id
);
88 -- WARNING: System.Tasking.Stages performs calls to this task with
89 -- low-level constructs. Do not change this spec without synchronizing it.
91 task Interrupt_Manager
is
92 entry Detach_Interrupt_Entries
(T
: Task_Id
);
94 entry Initialize
(Mask
: IMNG
.Interrupt_Mask
);
97 (New_Handler
: Parameterless_Handler
;
98 Interrupt
: Interrupt_ID
;
100 Restoration
: Boolean := False);
102 entry Exchange_Handler
103 (Old_Handler
: out Parameterless_Handler
;
104 New_Handler
: Parameterless_Handler
;
105 Interrupt
: Interrupt_ID
;
109 (Interrupt
: Interrupt_ID
;
112 entry Bind_Interrupt_To_Entry
114 E
: Task_Entry_Index
;
115 Interrupt
: Interrupt_ID
);
117 entry Block_Interrupt
(Interrupt
: Interrupt_ID
);
119 entry Unblock_Interrupt
(Interrupt
: Interrupt_ID
);
121 entry Ignore_Interrupt
(Interrupt
: Interrupt_ID
);
123 entry Unignore_Interrupt
(Interrupt
: Interrupt_ID
);
125 pragma Interrupt_Priority
(System
.Interrupt_Priority
'Last);
126 end Interrupt_Manager
;
128 task type Server_Task
(Interrupt
: Interrupt_ID
) is
129 pragma Priority
(System
.Interrupt_Priority
'Last);
130 -- Note: the above pragma Priority is strictly speaking improper since
131 -- it is outside the range of allowed priorities, but the compiler
132 -- treats system units specially and does not apply this range checking
133 -- rule to system units.
137 type Server_Task_Access
is access Server_Task
;
139 -------------------------------
140 -- Local Types and Variables --
141 -------------------------------
143 type Entry_Assoc
is record
145 E
: Task_Entry_Index
;
148 type Handler_Assoc
is record
149 H
: Parameterless_Handler
;
150 Static
: Boolean; -- Indicates static binding;
153 User_Handler
: array (Interrupt_ID
'Range) of Handler_Assoc
:=
154 (others => (null, Static
=> False));
155 pragma Volatile_Components
(User_Handler
);
156 -- Holds the protected procedure handler (if any) and its Static
157 -- information for each interrupt. A handler is a Static one if it is
158 -- specified through the pragma Attach_Handler. Attach_Handler. Otherwise,
161 User_Entry
: array (Interrupt_ID
'Range) of Entry_Assoc
:=
162 (others => (T
=> Null_Task
, E
=> Null_Task_Entry
));
163 pragma Volatile_Components
(User_Entry
);
164 -- Holds the task and entry index (if any) for each interrupt
166 Blocked
: constant array (Interrupt_ID
'Range) of Boolean :=
168 -- ??? pragma Volatile_Components (Blocked);
169 -- True iff the corresponding interrupt is blocked in the process level
171 Ignored
: array (Interrupt_ID
'Range) of Boolean := (others => False);
172 pragma Volatile_Components
(Ignored
);
173 -- True iff the corresponding interrupt is blocked in the process level
175 Last_Unblocker
: constant array (Interrupt_ID
'Range) of Task_Id
:=
176 (others => Null_Task
);
177 -- ??? pragma Volatile_Components (Last_Unblocker);
178 -- Holds the ID of the last Task which Unblocked this Interrupt.
179 -- It contains Null_Task if no tasks have ever requested the
180 -- Unblocking operation or the Interrupt is currently Blocked.
182 Server_ID
: array (Interrupt_ID
'Range) of Task_Id
:=
183 (others => Null_Task
);
184 pragma Atomic_Components
(Server_ID
);
185 -- Holds the Task_Id of the Server_Task for each interrupt. Task_Id is
186 -- needed to accomplish locking per Interrupt base. Also is needed to
187 -- decide whether to create a new Server_Task.
189 -- Type and Head, Tail of the list containing Registered Interrupt
190 -- Handlers. These definitions are used to register the handlers specified
191 -- by the pragma Interrupt_Handler.
193 type Registered_Handler
;
194 type R_Link
is access all Registered_Handler
;
196 type Registered_Handler
is record
197 H
: System
.Address
:= System
.Null_Address
;
198 Next
: R_Link
:= null;
201 Registered_Handler_Head
: R_Link
:= null;
202 Registered_Handler_Tail
: R_Link
:= null;
204 Access_Hold
: Server_Task_Access
;
205 -- variable used to allocate Server_Task using "new"
207 -----------------------
208 -- Local Subprograms --
209 -----------------------
211 function Is_Registered
(Handler
: Parameterless_Handler
) return Boolean;
212 -- See if the Handler has been "pragma"ed using Interrupt_Handler.
213 -- Always consider a null handler as registered.
215 --------------------------------
216 -- Register_Interrupt_Handler --
217 --------------------------------
219 procedure Register_Interrupt_Handler
(Handler_Addr
: System
.Address
) is
220 New_Node_Ptr
: R_Link
;
223 -- This routine registers the Handler as usable for Dynamic
224 -- Interrupt Handler. Routines attaching and detaching Handler
225 -- dynamically should first consult if the Handler is registered.
226 -- A Program Error should be raised if it is not registered.
228 -- The pragma Interrupt_Handler can only appear in the library
229 -- level PO definition and instantiation. Therefore, we do not need
230 -- to implement Unregistering operation. Neither we need to
231 -- protect the queue structure using a Lock.
233 pragma Assert
(Handler_Addr
/= System
.Null_Address
);
235 New_Node_Ptr
:= new Registered_Handler
;
236 New_Node_Ptr
.H
:= Handler_Addr
;
238 if Registered_Handler_Head
= null then
239 Registered_Handler_Head
:= New_Node_Ptr
;
240 Registered_Handler_Tail
:= New_Node_Ptr
;
243 Registered_Handler_Tail
.Next
:= New_Node_Ptr
;
244 Registered_Handler_Tail
:= New_Node_Ptr
;
246 end Register_Interrupt_Handler
;
252 function Is_Registered
(Handler
: Parameterless_Handler
) return Boolean is
253 type Fat_Ptr
is record
254 Object_Addr
: System
.Address
;
255 Handler_Addr
: System
.Address
;
258 function To_Fat_Ptr
is new Ada
.Unchecked_Conversion
259 (Parameterless_Handler
, Fat_Ptr
);
265 if Handler
= null then
269 Fat
:= To_Fat_Ptr
(Handler
);
271 Ptr
:= Registered_Handler_Head
;
273 while Ptr
/= null loop
274 if Ptr
.H
= Fat
.Handler_Addr
then
288 function Is_Reserved
(Interrupt
: Interrupt_ID
) return Boolean is
290 return IMNG
.Reserve
(IMNG
.Interrupt_ID
(Interrupt
));
293 -----------------------
294 -- Is_Entry_Attached --
295 -----------------------
297 function Is_Entry_Attached
(Interrupt
: Interrupt_ID
) return Boolean is
299 if Is_Reserved
(Interrupt
) then
300 raise Program_Error
with
301 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
304 return User_Entry
(Interrupt
).T
/= Null_Task
;
305 end Is_Entry_Attached
;
307 -------------------------
308 -- Is_Handler_Attached --
309 -------------------------
311 function Is_Handler_Attached
(Interrupt
: Interrupt_ID
) return Boolean is
313 if Is_Reserved
(Interrupt
) then
314 raise Program_Error
with
315 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
318 return User_Handler
(Interrupt
).H
/= null;
319 end Is_Handler_Attached
;
325 function Is_Blocked
(Interrupt
: Interrupt_ID
) return Boolean is
327 if Is_Reserved
(Interrupt
) then
328 raise Program_Error
with
329 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
332 return Blocked
(Interrupt
);
339 function Is_Ignored
(Interrupt
: Interrupt_ID
) return Boolean is
341 if Is_Reserved
(Interrupt
) then
342 raise Program_Error
with
343 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
346 return Ignored
(Interrupt
);
349 ---------------------
350 -- Current_Handler --
351 ---------------------
353 function Current_Handler
354 (Interrupt
: Interrupt_ID
) return Parameterless_Handler
357 if Is_Reserved
(Interrupt
) then
358 raise Program_Error
with
359 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
362 -- ??? Since Parameterless_Handler is not Atomic, the current
363 -- implementation is wrong. We need a new service in Interrupt_Manager
364 -- to ensure atomicity.
366 return User_Handler
(Interrupt
).H
;
373 -- Calling this procedure with New_Handler = null and Static = True
374 -- means we want to detach the current handler regardless of the
375 -- previous handler's binding status (i.e. do not care if it is a
376 -- dynamic or static handler).
378 -- This option is needed so that during the finalization of a PO, we
379 -- can detach handlers attached through pragma Attach_Handler.
381 procedure Attach_Handler
382 (New_Handler
: Parameterless_Handler
;
383 Interrupt
: Interrupt_ID
;
384 Static
: Boolean := False) is
386 if Is_Reserved
(Interrupt
) then
387 raise Program_Error
with
388 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
391 Interrupt_Manager
.Attach_Handler
(New_Handler
, Interrupt
, Static
);
395 ----------------------
396 -- Exchange_Handler --
397 ----------------------
399 -- Calling this procedure with New_Handler = null and Static = True means
400 -- we want to detach the current handler regardless of the previous
401 -- handler's binding status (i.e. do not care if it is dynamic or static
404 -- This option is needed so that during the finalization of a PO, we can
405 -- detach handlers attached through pragma Attach_Handler.
407 procedure Exchange_Handler
408 (Old_Handler
: out Parameterless_Handler
;
409 New_Handler
: Parameterless_Handler
;
410 Interrupt
: Interrupt_ID
;
411 Static
: Boolean := False)
414 if Is_Reserved
(Interrupt
) then
415 raise Program_Error
with
416 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
419 Interrupt_Manager
.Exchange_Handler
420 (Old_Handler
, New_Handler
, Interrupt
, Static
);
422 end Exchange_Handler
;
428 -- Calling this procedure with Static = True means we want to Detach the
429 -- current handler regardless of the previous handler's binding status
430 -- (i.e. do not care if it is a dynamic or static handler).
432 -- This option is needed so that during the finalization of a PO, we can
433 -- detach handlers attached through pragma Attach_Handler.
435 procedure Detach_Handler
436 (Interrupt
: Interrupt_ID
;
437 Static
: Boolean := False)
440 if Is_Reserved
(Interrupt
) then
441 raise Program_Error
with
442 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
445 Interrupt_Manager
.Detach_Handler
(Interrupt
, Static
);
452 function Reference
(Interrupt
: Interrupt_ID
) return System
.Address
is
454 if Is_Reserved
(Interrupt
) then
455 raise Program_Error
with
456 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
459 return Storage_Elements
.To_Address
460 (Storage_Elements
.Integer_Address
(Interrupt
));
463 -----------------------------
464 -- Bind_Interrupt_To_Entry --
465 -----------------------------
467 -- This procedure raises a Program_Error if it tries to
468 -- bind an interrupt to which an Entry or a Procedure is
471 procedure Bind_Interrupt_To_Entry
473 E
: Task_Entry_Index
;
474 Int_Ref
: System
.Address
)
476 Interrupt
: constant Interrupt_ID
:=
477 Interrupt_ID
(Storage_Elements
.To_Integer
(Int_Ref
));
480 if Is_Reserved
(Interrupt
) then
481 raise Program_Error
with
482 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
485 Interrupt_Manager
.Bind_Interrupt_To_Entry
(T
, E
, Interrupt
);
487 end Bind_Interrupt_To_Entry
;
489 ------------------------------
490 -- Detach_Interrupt_Entries --
491 ------------------------------
493 procedure Detach_Interrupt_Entries
(T
: Task_Id
) is
495 Interrupt_Manager
.Detach_Interrupt_Entries
(T
);
496 end Detach_Interrupt_Entries
;
498 ---------------------
499 -- Block_Interrupt --
500 ---------------------
502 procedure Block_Interrupt
(Interrupt
: Interrupt_ID
) is
504 if Is_Reserved
(Interrupt
) then
505 raise Program_Error
with
506 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
509 Interrupt_Manager
.Block_Interrupt
(Interrupt
);
512 -----------------------
513 -- Unblock_Interrupt --
514 -----------------------
516 procedure Unblock_Interrupt
(Interrupt
: Interrupt_ID
) is
518 if Is_Reserved
(Interrupt
) then
519 raise Program_Error
with
520 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
523 Interrupt_Manager
.Unblock_Interrupt
(Interrupt
);
524 end Unblock_Interrupt
;
530 function Unblocked_By
531 (Interrupt
: Interrupt_ID
) return System
.Tasking
.Task_Id
is
533 if Is_Reserved
(Interrupt
) then
534 raise Program_Error
with
535 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
538 return Last_Unblocker
(Interrupt
);
541 ----------------------
542 -- Ignore_Interrupt --
543 ----------------------
545 procedure Ignore_Interrupt
(Interrupt
: Interrupt_ID
) is
547 if Is_Reserved
(Interrupt
) then
548 raise Program_Error
with
549 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
552 Interrupt_Manager
.Ignore_Interrupt
(Interrupt
);
553 end Ignore_Interrupt
;
555 ------------------------
556 -- Unignore_Interrupt --
557 ------------------------
559 procedure Unignore_Interrupt
(Interrupt
: Interrupt_ID
) is
561 if Is_Reserved
(Interrupt
) then
562 raise Program_Error
with
563 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
566 Interrupt_Manager
.Unignore_Interrupt
(Interrupt
);
567 end Unignore_Interrupt
;
569 -----------------------
570 -- Interrupt_Manager --
571 -----------------------
573 task body Interrupt_Manager
is
579 procedure Unprotected_Exchange_Handler
580 (Old_Handler
: out Parameterless_Handler
;
581 New_Handler
: Parameterless_Handler
;
582 Interrupt
: Interrupt_ID
;
584 Restoration
: Boolean := False);
586 procedure Unprotected_Detach_Handler
587 (Interrupt
: Interrupt_ID
;
590 ----------------------------------
591 -- Unprotected_Exchange_Handler --
592 ----------------------------------
594 procedure Unprotected_Exchange_Handler
595 (Old_Handler
: out Parameterless_Handler
;
596 New_Handler
: Parameterless_Handler
;
597 Interrupt
: Interrupt_ID
;
599 Restoration
: Boolean := False)
602 if User_Entry
(Interrupt
).T
/= Null_Task
then
604 -- In case we have an Interrupt Entry already installed.
605 -- raise a program error. (propagate it to the caller).
607 raise Program_Error
with "An interrupt is already installed";
610 -- Note: A null handler with Static=True will pass the following
611 -- check. That is the case when we want to Detach a handler
612 -- regardless of the Static status of the current_Handler. We don't
613 -- check anything if Restoration is True, since we may be detaching
614 -- a static handler to restore a dynamic one.
616 if not Restoration
and then not Static
618 -- Tries to overwrite a static Interrupt Handler with a
621 and then (User_Handler
(Interrupt
).Static
623 -- The new handler is not specified as an
624 -- Interrupt Handler by a pragma.
626 or else not Is_Registered
(New_Handler
))
628 raise Program_Error
with
629 "Trying to overwrite a static Interrupt Handler with a " &
633 -- The interrupt should no longer be ignored if it was ever ignored
635 Ignored
(Interrupt
) := False;
637 -- Save the old handler
639 Old_Handler
:= User_Handler
(Interrupt
).H
;
643 User_Handler
(Interrupt
).H
:= New_Handler
;
645 if New_Handler
= null then
647 -- The null handler means we are detaching the handler
649 User_Handler
(Interrupt
).Static
:= False;
652 User_Handler
(Interrupt
).Static
:= Static
;
655 -- Invoke a corresponding Server_Task if not yet created.
656 -- Place Task_Id info in Server_ID array.
658 if Server_ID
(Interrupt
) = Null_Task
then
659 Access_Hold
:= new Server_Task
(Interrupt
);
660 Server_ID
(Interrupt
) := To_System
(Access_Hold
.all'Identity);
662 POP
.Wakeup
(Server_ID
(Interrupt
), Interrupt_Server_Idle_Sleep
);
665 end Unprotected_Exchange_Handler
;
667 --------------------------------
668 -- Unprotected_Detach_Handler --
669 --------------------------------
671 procedure Unprotected_Detach_Handler
672 (Interrupt
: Interrupt_ID
;
676 if User_Entry
(Interrupt
).T
/= Null_Task
then
678 -- In case we have an Interrupt Entry installed.
679 -- raise a program error. (propagate it to the caller).
681 raise Program_Error
with
682 "An interrupt entry is already installed";
685 -- Note : Static = True will pass the following check. That is the
686 -- case when we want to detach a handler regardless of the static
687 -- status of the current_Handler.
689 if not Static
and then User_Handler
(Interrupt
).Static
then
690 -- Tries to detach a static Interrupt Handler.
691 -- raise a program error.
693 raise Program_Error
with
694 "Trying to detach a static Interrupt Handler";
697 -- The interrupt should no longer be ignored if
698 -- it was ever ignored.
700 Ignored
(Interrupt
) := False;
704 User_Handler
(Interrupt
).H
:= null;
705 User_Handler
(Interrupt
).Static
:= False;
706 IMOP
.Interrupt_Self_Process
(IMNG
.Interrupt_ID
(Interrupt
));
708 end Unprotected_Detach_Handler
;
710 -- Start of processing for Interrupt_Manager
713 -- By making this task independent of master, when the process
714 -- goes away, the Interrupt_Manager will terminate gracefully.
716 System
.Tasking
.Utilities
.Make_Independent
;
718 -- Environment task gets its own interrupt mask, saves it,
719 -- and then masks all interrupts except the Keep_Unmasked set.
721 -- During rendezvous, the Interrupt_Manager receives the old
722 -- interrupt mask of the environment task, and sets its own
723 -- interrupt mask to that value.
725 -- The environment task will call the entry of Interrupt_Manager some
726 -- during elaboration of the body of this package.
728 accept Initialize
(Mask
: IMNG
.Interrupt_Mask
) do
729 pragma Warnings
(Off
, Mask
);
733 -- Note: All tasks in RTS will have all the Reserve Interrupts
734 -- being masked (except the Interrupt_Manager) and Keep_Unmasked
735 -- unmasked when created.
737 -- Abort_Task_Interrupt is one of the Interrupt unmasked
738 -- in all tasks. We mask the Interrupt in this particular task
739 -- so that "sigwait" is possible to catch an explicitly sent
740 -- Abort_Task_Interrupt from the Server_Tasks.
742 -- This sigwaiting is needed so that we make sure a Server_Task is
743 -- out of its own sigwait state. This extra synchronization is
744 -- necessary to prevent following scenarios.
746 -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to the
747 -- Server_Task then changes its own interrupt mask (OS level).
748 -- If an interrupt (corresponding to the Server_Task) arrives
749 -- in the mean time we have the Interrupt_Manager unmasked and
750 -- the Server_Task waiting on sigwait.
752 -- 2) For unbinding handler, we install a default action in the
753 -- Interrupt_Manager. POSIX.1c states that the result of using
754 -- "sigwait" and "sigaction" simultaneously on the same interrupt
755 -- is undefined. Therefore, we need to be informed from the
756 -- Server_Task of the fact that the Server_Task is out of its
760 -- A block is needed to absorb Program_Error exception
763 Old_Handler
: Parameterless_Handler
;
767 accept Attach_Handler
768 (New_Handler
: Parameterless_Handler
;
769 Interrupt
: Interrupt_ID
;
771 Restoration
: Boolean := False)
773 Unprotected_Exchange_Handler
774 (Old_Handler
, New_Handler
, Interrupt
, Static
, Restoration
);
777 or accept Exchange_Handler
778 (Old_Handler
: out Parameterless_Handler
;
779 New_Handler
: Parameterless_Handler
;
780 Interrupt
: Interrupt_ID
;
783 Unprotected_Exchange_Handler
784 (Old_Handler
, New_Handler
, Interrupt
, Static
);
785 end Exchange_Handler
;
787 or accept Detach_Handler
788 (Interrupt
: Interrupt_ID
;
791 Unprotected_Detach_Handler
(Interrupt
, Static
);
794 or accept Bind_Interrupt_To_Entry
796 E
: Task_Entry_Index
;
797 Interrupt
: Interrupt_ID
)
799 -- if there is a binding already (either a procedure or an
800 -- entry), raise Program_Error (propagate it to the caller).
802 if User_Handler
(Interrupt
).H
/= null
803 or else User_Entry
(Interrupt
).T
/= Null_Task
805 raise Program_Error
with
806 "A binding for this interrupt is already present";
809 -- The interrupt should no longer be ignored if
810 -- it was ever ignored.
812 Ignored
(Interrupt
) := False;
813 User_Entry
(Interrupt
) := Entry_Assoc
'(T => T, E => E);
815 -- Indicate the attachment of Interrupt Entry in ATCB.
816 -- This is need so that when an Interrupt Entry task
817 -- terminates the binding can be cleaned.
818 -- The call to unbinding must be
819 -- make by the task before it terminates.
821 T.Interrupt_Entry := True;
823 -- Invoke a corresponding Server_Task if not yet created.
824 -- Place Task_Id info in Server_ID array.
826 if Server_ID (Interrupt) = Null_Task then
828 Access_Hold := new Server_Task (Interrupt);
829 Server_ID (Interrupt) :=
830 To_System (Access_Hold.all'Identity);
832 POP.Wakeup (Server_ID (Interrupt),
833 Interrupt_Server_Idle_Sleep);
835 end Bind_Interrupt_To_Entry;
837 or accept Detach_Interrupt_Entries (T : Task_Id)
839 for J in Interrupt_ID'Range loop
840 if not Is_Reserved (J) then
841 if User_Entry (J).T = T then
843 -- The interrupt should no longer be ignored if
844 -- it was ever ignored.
846 Ignored (J) := False;
848 Entry_Assoc'(T
=> Null_Task
, E
=> Null_Task_Entry
);
849 IMOP
.Interrupt_Self_Process
(IMNG
.Interrupt_ID
(J
));
854 -- Indicate in ATCB that no Interrupt Entries are attached
856 T
.Interrupt_Entry
:= False;
857 end Detach_Interrupt_Entries
;
859 or accept Block_Interrupt
(Interrupt
: Interrupt_ID
) do
860 pragma Warnings
(Off
, Interrupt
);
864 or accept Unblock_Interrupt
(Interrupt
: Interrupt_ID
) do
865 pragma Warnings
(Off
, Interrupt
);
867 end Unblock_Interrupt
;
869 or accept Ignore_Interrupt
(Interrupt
: Interrupt_ID
) do
870 pragma Warnings
(Off
, Interrupt
);
872 end Ignore_Interrupt
;
874 or accept Unignore_Interrupt
(Interrupt
: Interrupt_ID
) do
875 pragma Warnings
(Off
, Interrupt
);
877 end Unignore_Interrupt
;
882 -- If there is a program error we just want to propagate it
883 -- to the caller and do not want to stop this task.
885 when Program_Error
=>
889 pragma Assert
(False);
893 end Interrupt_Manager
;
899 task body Server_Task
is
900 Self_ID
: constant Task_Id
:= Self
;
901 Tmp_Handler
: Parameterless_Handler
;
903 Tmp_Entry_Index
: Task_Entry_Index
;
904 Intwait_Mask
: aliased IMNG
.Interrupt_Mask
;
907 -- By making this task independent of master, when the process
908 -- goes away, the Server_Task will terminate gracefully.
910 System
.Tasking
.Utilities
.Make_Independent
;
912 -- Install default action in system level
914 IMOP
.Install_Default_Action
(IMNG
.Interrupt_ID
(Interrupt
));
916 -- Set up the mask (also clears the event flag)
918 IMOP
.Empty_Interrupt_Mask
(Intwait_Mask
'Access);
919 IMOP
.Add_To_Interrupt_Mask
920 (Intwait_Mask
'Access, IMNG
.Interrupt_ID
(Interrupt
));
922 -- Remember the Interrupt_ID for Abort_Task
924 PIO
.Set_Interrupt_ID
(IMNG
.Interrupt_ID
(Interrupt
), Self_ID
);
926 -- Note: All tasks in RTS will have all the Reserve Interrupts
927 -- being masked (except the Interrupt_Manager) and Keep_Unmasked
928 -- unmasked when created.
931 System
.Tasking
.Initialization
.Defer_Abort
(Self_ID
);
933 -- A Handler or an Entry is installed. At this point all tasks
934 -- mask for the Interrupt is masked. Catch the Interrupt using
937 -- This task may wake up from sigwait by receiving an interrupt
938 -- (Abort_Task_Interrupt) from the Interrupt_Manager for unbinding
939 -- a Procedure Handler or an Entry. Or it could be a wake up
940 -- from status change (Unblocked -> Blocked). If that is not
941 -- the case, we should execute the attached Procedure or Entry.
947 POP
.Write_Lock
(Self_ID
);
949 if User_Handler
(Interrupt
).H
= null
950 and then User_Entry
(Interrupt
).T
= Null_Task
952 -- No Interrupt binding. If there is an interrupt,
953 -- Interrupt_Manager will take default action.
955 Self_ID
.Common
.State
:= Interrupt_Server_Idle_Sleep
;
956 POP
.Sleep
(Self_ID
, Interrupt_Server_Idle_Sleep
);
957 Self_ID
.Common
.State
:= Runnable
;
960 Self_ID
.Common
.State
:= Interrupt_Server_Blocked_On_Event_Flag
;
961 Self_ID
.Common
.State
:= Runnable
;
963 if not (Self_ID
.Deferral_Level
= 0
964 and then Self_ID
.Pending_ATC_Level
965 < Self_ID
.ATC_Nesting_Level
)
967 if User_Handler
(Interrupt
).H
/= null then
968 Tmp_Handler
:= User_Handler
(Interrupt
).H
;
970 -- RTS calls should not be made with self being locked
972 POP
.Unlock
(Self_ID
);
984 POP
.Write_Lock
(Self_ID
);
986 elsif User_Entry
(Interrupt
).T
/= Null_Task
then
987 Tmp_ID
:= User_Entry
(Interrupt
).T
;
988 Tmp_Entry_Index
:= User_Entry
(Interrupt
).E
;
990 -- RTS calls should not be made with self being locked
992 POP
.Unlock
(Self_ID
);
998 System
.Tasking
.Rendezvous
.Call_Simple
999 (Tmp_ID
, Tmp_Entry_Index
, System
.Null_Address
);
1005 POP
.Write_Lock
(Self_ID
);
1010 POP
.Unlock
(Self_ID
);
1016 System
.Tasking
.Initialization
.Undefer_Abort
(Self_ID
);
1018 -- Undefer abort here to allow a window for this task
1019 -- to be aborted at the time of system shutdown.
1023 -------------------------------------
1024 -- Has_Interrupt_Or_Attach_Handler --
1025 -------------------------------------
1027 function Has_Interrupt_Or_Attach_Handler
1028 (Object
: access Dynamic_Interrupt_Protection
) return Boolean
1030 pragma Warnings
(Off
, Object
);
1034 end Has_Interrupt_Or_Attach_Handler
;
1040 procedure Finalize
(Object
: in out Static_Interrupt_Protection
) is
1042 -- ??? loop to be executed only when we're not doing library level
1043 -- finalization, since in this case all interrupt tasks are gone.
1045 if not Interrupt_Manager
'Terminated then
1046 for N
in reverse Object
.Previous_Handlers
'Range loop
1047 Interrupt_Manager
.Attach_Handler
1048 (New_Handler
=> Object
.Previous_Handlers
(N
).Handler
,
1049 Interrupt
=> Object
.Previous_Handlers
(N
).Interrupt
,
1050 Static
=> Object
.Previous_Handlers
(N
).Static
,
1051 Restoration
=> True);
1055 Tasking
.Protected_Objects
.Entries
.Finalize
1056 (Tasking
.Protected_Objects
.Entries
.Protection_Entries
(Object
));
1059 -------------------------------------
1060 -- Has_Interrupt_Or_Attach_Handler --
1061 -------------------------------------
1063 function Has_Interrupt_Or_Attach_Handler
1064 (Object
: access Static_Interrupt_Protection
) return Boolean
1066 pragma Warnings
(Off
, Object
);
1069 end Has_Interrupt_Or_Attach_Handler
;
1071 ----------------------
1072 -- Install_Handlers --
1073 ----------------------
1075 procedure Install_Handlers
1076 (Object
: access Static_Interrupt_Protection
;
1077 New_Handlers
: New_Handler_Array
)
1080 for N
in New_Handlers
'Range loop
1082 -- We need a lock around this ???
1084 Object
.Previous_Handlers
(N
).Interrupt
:= New_Handlers
(N
).Interrupt
;
1085 Object
.Previous_Handlers
(N
).Static
:= User_Handler
1086 (New_Handlers
(N
).Interrupt
).Static
;
1088 -- We call Exchange_Handler and not directly Interrupt_Manager.
1089 -- Exchange_Handler so we get the Is_Reserved check.
1092 (Old_Handler
=> Object
.Previous_Handlers
(N
).Handler
,
1093 New_Handler
=> New_Handlers
(N
).Handler
,
1094 Interrupt
=> New_Handlers
(N
).Interrupt
,
1097 end Install_Handlers
;
1099 ---------------------------------
1100 -- Install_Restricted_Handlers --
1101 ---------------------------------
1103 procedure Install_Restricted_Handlers
(Handlers
: New_Handler_Array
) is
1105 for N
in Handlers
'Range loop
1106 Attach_Handler
(Handlers
(N
).Handler
, Handlers
(N
).Interrupt
, True);
1108 end Install_Restricted_Handlers
;
1110 -- Elaboration code for package System.Interrupts
1113 -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent
1115 Interrupt_Manager_ID
:= To_System
(Interrupt_Manager
'Identity);
1117 -- During the elaboration of this package body we want RTS to inherit the
1118 -- interrupt mask from the Environment Task.
1120 -- The Environment Task should have gotten its mask from the enclosing
1121 -- process during the RTS start up. (See in s-inmaop.adb). Pass the
1122 -- Interrupt_Mask of the Environment task to the Interrupt_Manager.
1124 -- Note : At this point we know that all tasks (including RTS internal
1125 -- servers) are masked for non-reserved signals (see s-taprop.adb). Only
1126 -- the Interrupt_Manager will have masks set up differently inheriting the
1127 -- original Environment Task's mask.
1129 Interrupt_Manager
.Initialize
(IMOP
.Environment_Mask
);
1130 end System
.Interrupts
;