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-2014, 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 3, or (at your option) any later ver- --
14 -- sion. GNAT 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. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
30 ------------------------------------------------------------------------------
32 -- This is an OpenVMS/Alpha version of this package
36 -- Once we associate a Server_Task with an interrupt, the task never
37 -- goes away, and we never remove the association.
39 -- There is no more than one interrupt per Server_Task and no more than
40 -- one Server_Task per interrupt.
42 -- Within this package, the lock L is used to protect the various status
43 -- tables. If there is a Server_Task associated with an interrupt, we use
44 -- the per-task lock of the Server_Task instead so that we protect the
45 -- status between Interrupt_Manager and Server_Task. Protection among
46 -- service requests are done using User Request to Interrupt_Manager
49 with Ada
.Task_Identification
;
50 with Ada
.Unchecked_Conversion
;
52 with System
.Task_Primitives
;
53 with System
.Interrupt_Management
;
55 with System
.Interrupt_Management
.Operations
;
56 pragma Elaborate_All
(System
.Interrupt_Management
.Operations
);
58 with System
.Task_Primitives
.Operations
;
59 with System
.Task_Primitives
.Interrupt_Operations
;
60 with System
.Storage_Elements
;
61 with System
.Tasking
.Utilities
;
63 with System
.Tasking
.Rendezvous
;
64 pragma Elaborate_All
(System
.Tasking
.Rendezvous
);
66 with System
.Tasking
.Initialization
;
67 with System
.Parameters
;
69 package body System
.Interrupts
is
72 use System
.Parameters
;
74 package POP
renames System
.Task_Primitives
.Operations
;
75 package PIO
renames System
.Task_Primitives
.Interrupt_Operations
;
76 package IMNG
renames System
.Interrupt_Management
;
77 package IMOP
renames System
.Interrupt_Management
.Operations
;
79 function To_System
is new Ada
.Unchecked_Conversion
80 (Ada
.Task_Identification
.Task_Id
, Task_Id
);
86 -- WARNING: System.Tasking.Stages performs calls to this task with
87 -- low-level constructs. Do not change this spec without synchronizing it.
89 task Interrupt_Manager
is
90 entry Detach_Interrupt_Entries
(T
: Task_Id
);
92 entry Initialize
(Mask
: IMNG
.Interrupt_Mask
);
95 (New_Handler
: Parameterless_Handler
;
96 Interrupt
: Interrupt_ID
;
98 Restoration
: Boolean := False);
100 entry Exchange_Handler
101 (Old_Handler
: out Parameterless_Handler
;
102 New_Handler
: Parameterless_Handler
;
103 Interrupt
: Interrupt_ID
;
107 (Interrupt
: Interrupt_ID
;
110 entry Bind_Interrupt_To_Entry
112 E
: Task_Entry_Index
;
113 Interrupt
: Interrupt_ID
);
115 entry Block_Interrupt
(Interrupt
: Interrupt_ID
);
117 entry Unblock_Interrupt
(Interrupt
: Interrupt_ID
);
119 entry Ignore_Interrupt
(Interrupt
: Interrupt_ID
);
121 entry Unignore_Interrupt
(Interrupt
: Interrupt_ID
);
123 pragma Interrupt_Priority
(System
.Interrupt_Priority
'Last);
124 end Interrupt_Manager
;
126 task type Server_Task
(Interrupt
: Interrupt_ID
) is
127 pragma Priority
(System
.Interrupt_Priority
'Last);
128 -- Note: the above pragma Priority is strictly speaking improper since
129 -- it is outside the range of allowed priorities, but the compiler
130 -- treats system units specially and does not apply this range checking
131 -- rule to system units.
135 type Server_Task_Access
is access Server_Task
;
137 -------------------------------
138 -- Local Types and Variables --
139 -------------------------------
141 type Entry_Assoc
is record
143 E
: Task_Entry_Index
;
146 type Handler_Assoc
is record
147 H
: Parameterless_Handler
;
148 Static
: Boolean; -- Indicates static binding;
151 User_Handler
: array (Interrupt_ID
'Range) of Handler_Assoc
:=
152 (others => (null, Static
=> False));
153 pragma Volatile_Components
(User_Handler
);
154 -- Holds the protected procedure handler (if any) and its Static
155 -- information for each interrupt. A handler is a Static one if it is
156 -- specified through the pragma Attach_Handler. Attach_Handler. Otherwise,
159 User_Entry
: array (Interrupt_ID
'Range) of Entry_Assoc
:=
160 (others => (T
=> Null_Task
, E
=> Null_Task_Entry
));
161 pragma Volatile_Components
(User_Entry
);
162 -- Holds the task and entry index (if any) for each interrupt
164 Blocked
: constant array (Interrupt_ID
'Range) of Boolean :=
166 -- ??? pragma Volatile_Components (Blocked);
167 -- True iff the corresponding interrupt is blocked in the process level
169 Ignored
: array (Interrupt_ID
'Range) of Boolean := (others => False);
170 pragma Volatile_Components
(Ignored
);
171 -- True iff the corresponding interrupt is blocked in the process level
173 Last_Unblocker
: constant array (Interrupt_ID
'Range) of Task_Id
:=
174 (others => Null_Task
);
175 -- ??? pragma Volatile_Components (Last_Unblocker);
176 -- Holds the ID of the last Task which Unblocked this Interrupt. It
177 -- contains Null_Task if no tasks have ever requested the Unblocking
178 -- operation or the Interrupt is currently Blocked.
180 Server_ID
: array (Interrupt_ID
'Range) of Task_Id
:=
181 (others => Null_Task
);
182 pragma Atomic_Components
(Server_ID
);
183 -- Holds the Task_Id of the Server_Task for each interrupt. Task_Id is
184 -- needed to accomplish locking per Interrupt base. Also is needed to
185 -- decide whether to create a new Server_Task.
187 -- Type and Head, Tail of the list containing Registered Interrupt
188 -- Handlers. These definitions are used to register the handlers
189 -- specified by the pragma Interrupt_Handler.
191 type Registered_Handler
;
192 type R_Link
is access all Registered_Handler
;
194 type Registered_Handler
is record
195 H
: System
.Address
:= System
.Null_Address
;
196 Next
: R_Link
:= null;
199 Registered_Handler_Head
: R_Link
:= null;
200 Registered_Handler_Tail
: R_Link
:= null;
202 Access_Hold
: Server_Task_Access
;
203 -- variable used to allocate Server_Task using "new"
205 -----------------------
206 -- Local Subprograms --
207 -----------------------
209 function Is_Registered
(Handler
: Parameterless_Handler
) return Boolean;
210 -- See if the Handler has been "pragma"ed using Interrupt_Handler.
211 -- Always consider a null handler as registered.
213 --------------------------------
214 -- Register_Interrupt_Handler --
215 --------------------------------
217 procedure Register_Interrupt_Handler
(Handler_Addr
: System
.Address
) is
218 New_Node_Ptr
: R_Link
;
221 -- This routine registers the Handler as usable for Dynamic Interrupt
222 -- Handler. Routines attaching and detaching Handler dynamically should
223 -- first consult if the Handler is registered. A Program Error should be
224 -- raised if it is not registered.
226 -- The pragma Interrupt_Handler can only appear in the library level PO
227 -- definition and instantiation. Therefore, we do not need to implement
228 -- Unregistering operation. Neither we need to protect the queue
229 -- structure using a Lock.
231 pragma Assert
(Handler_Addr
/= System
.Null_Address
);
233 New_Node_Ptr
:= new Registered_Handler
;
234 New_Node_Ptr
.H
:= Handler_Addr
;
236 if Registered_Handler_Head
= null then
237 Registered_Handler_Head
:= New_Node_Ptr
;
238 Registered_Handler_Tail
:= New_Node_Ptr
;
241 Registered_Handler_Tail
.Next
:= New_Node_Ptr
;
242 Registered_Handler_Tail
:= New_Node_Ptr
;
244 end Register_Interrupt_Handler
;
250 function Is_Registered
(Handler
: Parameterless_Handler
) return Boolean is
251 type Fat_Ptr
is record
252 Object_Addr
: System
.Address
;
253 Handler_Addr
: System
.Address
;
256 function To_Fat_Ptr
is new Ada
.Unchecked_Conversion
257 (Parameterless_Handler
, Fat_Ptr
);
263 if Handler
= null then
267 Fat
:= To_Fat_Ptr
(Handler
);
269 Ptr
:= Registered_Handler_Head
;
270 while Ptr
/= null loop
271 if Ptr
.H
= Fat
.Handler_Addr
then
285 function Is_Reserved
(Interrupt
: Interrupt_ID
) return Boolean is
287 return IMNG
.Reserve
(IMNG
.Interrupt_ID
(Interrupt
));
290 -----------------------
291 -- Is_Entry_Attached --
292 -----------------------
294 function Is_Entry_Attached
(Interrupt
: Interrupt_ID
) return Boolean is
296 if Is_Reserved
(Interrupt
) then
297 raise Program_Error
with
298 "interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
301 return User_Entry
(Interrupt
).T
/= Null_Task
;
302 end Is_Entry_Attached
;
304 -------------------------
305 -- Is_Handler_Attached --
306 -------------------------
308 function Is_Handler_Attached
(Interrupt
: Interrupt_ID
) return Boolean is
310 if Is_Reserved
(Interrupt
) then
311 raise Program_Error
with
312 "interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
315 return User_Handler
(Interrupt
).H
/= null;
316 end Is_Handler_Attached
;
322 function Is_Blocked
(Interrupt
: Interrupt_ID
) return Boolean is
324 if Is_Reserved
(Interrupt
) then
325 raise Program_Error
with
326 "interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
329 return Blocked
(Interrupt
);
336 function Is_Ignored
(Interrupt
: Interrupt_ID
) return Boolean is
338 if Is_Reserved
(Interrupt
) then
339 raise Program_Error
with
340 "interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
343 return Ignored
(Interrupt
);
346 ---------------------
347 -- Current_Handler --
348 ---------------------
350 function Current_Handler
351 (Interrupt
: Interrupt_ID
) return Parameterless_Handler
354 if Is_Reserved
(Interrupt
) then
355 raise Program_Error
with
356 "interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
359 -- ??? Since Parameterless_Handler is not Atomic, the current
360 -- implementation is wrong. We need a new service in Interrupt_Manager
361 -- to ensure atomicity.
363 return User_Handler
(Interrupt
).H
;
370 -- Calling this procedure with New_Handler = null and Static = True
371 -- means we want to detach the current handler regardless of the previous
372 -- handler's binding status (i.e. we do not care if it is a dynamic or
375 -- This option is needed so that during the finalization of a PO, we
376 -- can detach handlers attached through pragma Attach_Handler.
378 procedure Attach_Handler
379 (New_Handler
: Parameterless_Handler
;
380 Interrupt
: Interrupt_ID
;
381 Static
: Boolean := False)
384 if Is_Reserved
(Interrupt
) then
385 raise Program_Error
with
386 "interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
389 Interrupt_Manager
.Attach_Handler
(New_Handler
, Interrupt
, Static
);
392 ----------------------
393 -- Exchange_Handler --
394 ----------------------
396 -- Calling this procedure with New_Handler = null and Static = True means
397 -- we want to detach the current handler regardless of the previous
398 -- handler's binding status (i.e. do not care if it is dynamic or static
401 -- This option is needed so that during the finalization of a PO, we can
402 -- detach handlers attached through pragma Attach_Handler.
404 procedure Exchange_Handler
405 (Old_Handler
: out Parameterless_Handler
;
406 New_Handler
: Parameterless_Handler
;
407 Interrupt
: Interrupt_ID
;
408 Static
: Boolean := False)
411 if Is_Reserved
(Interrupt
) then
412 raise Program_Error
with
413 "interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
416 Interrupt_Manager
.Exchange_Handler
417 (Old_Handler
, New_Handler
, Interrupt
, Static
);
418 end Exchange_Handler
;
424 -- Calling this procedure with Static = True means we want to Detach the
425 -- current handler regardless of the previous handler's binding status
426 -- (i.e. do not care if it is a dynamic or static handler).
428 -- This option is needed so that during the finalization of a PO, we can
429 -- detach handlers attached through pragma Attach_Handler.
431 procedure Detach_Handler
432 (Interrupt
: Interrupt_ID
;
433 Static
: Boolean := False)
436 if Is_Reserved
(Interrupt
) then
437 raise Program_Error
with
438 "interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
441 Interrupt_Manager
.Detach_Handler
(Interrupt
, Static
);
448 function Reference
(Interrupt
: Interrupt_ID
) return System
.Address
is
450 if Is_Reserved
(Interrupt
) then
451 raise Program_Error
with
452 "interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
455 return Storage_Elements
.To_Address
456 (Storage_Elements
.Integer_Address
(Interrupt
));
459 -----------------------------
460 -- Bind_Interrupt_To_Entry --
461 -----------------------------
463 -- This procedure raises a Program_Error if it tries to
464 -- bind an interrupt to which an Entry or a Procedure is
467 procedure Bind_Interrupt_To_Entry
469 E
: Task_Entry_Index
;
470 Int_Ref
: System
.Address
)
472 Interrupt
: constant Interrupt_ID
:=
473 Interrupt_ID
(Storage_Elements
.To_Integer
(Int_Ref
));
476 if Is_Reserved
(Interrupt
) then
477 raise Program_Error
with
478 "interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
481 Interrupt_Manager
.Bind_Interrupt_To_Entry
(T
, E
, Interrupt
);
482 end Bind_Interrupt_To_Entry
;
484 ------------------------------
485 -- Detach_Interrupt_Entries --
486 ------------------------------
488 procedure Detach_Interrupt_Entries
(T
: Task_Id
) is
490 Interrupt_Manager
.Detach_Interrupt_Entries
(T
);
491 end Detach_Interrupt_Entries
;
493 ---------------------
494 -- Block_Interrupt --
495 ---------------------
497 procedure Block_Interrupt
(Interrupt
: Interrupt_ID
) is
499 if Is_Reserved
(Interrupt
) then
500 raise Program_Error
with
501 "interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
504 Interrupt_Manager
.Block_Interrupt
(Interrupt
);
507 -----------------------
508 -- Unblock_Interrupt --
509 -----------------------
511 procedure Unblock_Interrupt
(Interrupt
: Interrupt_ID
) is
513 if Is_Reserved
(Interrupt
) then
514 raise Program_Error
with
515 "interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
518 Interrupt_Manager
.Unblock_Interrupt
(Interrupt
);
519 end Unblock_Interrupt
;
525 function Unblocked_By
526 (Interrupt
: Interrupt_ID
) return System
.Tasking
.Task_Id
is
528 if Is_Reserved
(Interrupt
) then
529 raise Program_Error
with
530 "interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
533 return Last_Unblocker
(Interrupt
);
536 ----------------------
537 -- Ignore_Interrupt --
538 ----------------------
540 procedure Ignore_Interrupt
(Interrupt
: Interrupt_ID
) is
542 if Is_Reserved
(Interrupt
) then
543 raise Program_Error
with
544 "interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
547 Interrupt_Manager
.Ignore_Interrupt
(Interrupt
);
548 end Ignore_Interrupt
;
550 ------------------------
551 -- Unignore_Interrupt --
552 ------------------------
554 procedure Unignore_Interrupt
(Interrupt
: Interrupt_ID
) is
556 if Is_Reserved
(Interrupt
) then
557 raise Program_Error
with
558 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
561 Interrupt_Manager
.Unignore_Interrupt
(Interrupt
);
562 end Unignore_Interrupt
;
564 -----------------------
565 -- Interrupt_Manager --
566 -----------------------
568 task body Interrupt_Manager
is
574 procedure Unprotected_Exchange_Handler
575 (Old_Handler
: out Parameterless_Handler
;
576 New_Handler
: Parameterless_Handler
;
577 Interrupt
: Interrupt_ID
;
579 Restoration
: Boolean := False);
581 procedure Unprotected_Detach_Handler
582 (Interrupt
: Interrupt_ID
;
585 ----------------------------------
586 -- Unprotected_Exchange_Handler --
587 ----------------------------------
589 procedure Unprotected_Exchange_Handler
590 (Old_Handler
: out Parameterless_Handler
;
591 New_Handler
: Parameterless_Handler
;
592 Interrupt
: Interrupt_ID
;
594 Restoration
: Boolean := False)
597 if User_Entry
(Interrupt
).T
/= Null_Task
then
599 -- In case we have an Interrupt Entry already installed.
600 -- raise a program error. (propagate it to the caller).
602 raise Program_Error
with "an interrupt is already installed";
605 -- Note: A null handler with Static=True will pass the following
606 -- check. That is the case when we want to Detach a handler
607 -- regardless of the Static status of the current_Handler. We don't
608 -- check anything if Restoration is True, since we may be detaching
609 -- a static handler to restore a dynamic one.
611 if not Restoration
and then not Static
613 -- Tries to overwrite a static Interrupt Handler with a
616 and then (User_Handler
(Interrupt
).Static
618 -- The new handler is not specified as an
619 -- Interrupt Handler by a pragma.
621 or else not Is_Registered
(New_Handler
))
623 raise Program_Error
with
624 "trying to overwrite a static interrupt handler with a " &
628 -- The interrupt should no longer be ignored if it was ever ignored
630 Ignored
(Interrupt
) := False;
632 -- Save the old handler
634 Old_Handler
:= User_Handler
(Interrupt
).H
;
638 User_Handler
(Interrupt
).H
:= New_Handler
;
640 if New_Handler
= null then
642 -- The null handler means we are detaching the handler
644 User_Handler
(Interrupt
).Static
:= False;
647 User_Handler
(Interrupt
).Static
:= Static
;
650 -- Invoke a corresponding Server_Task if not yet created.
651 -- Place Task_Id info in Server_ID array.
653 if Server_ID
(Interrupt
) = Null_Task
then
654 Access_Hold
:= new Server_Task
(Interrupt
);
655 Server_ID
(Interrupt
) := To_System
(Access_Hold
.all'Identity);
657 POP
.Wakeup
(Server_ID
(Interrupt
), Interrupt_Server_Idle_Sleep
);
660 end Unprotected_Exchange_Handler
;
662 --------------------------------
663 -- Unprotected_Detach_Handler --
664 --------------------------------
666 procedure Unprotected_Detach_Handler
667 (Interrupt
: Interrupt_ID
;
671 if User_Entry
(Interrupt
).T
/= Null_Task
then
673 -- In case we have an Interrupt Entry installed, raise a program
674 -- error, (propagate it to the caller).
676 raise Program_Error
with
677 "an interrupt entry is already installed";
680 -- Note : Static = True will pass the following check. That is the
681 -- case when we want to detach a handler regardless of the static
682 -- status of the current_Handler.
684 if not Static
and then User_Handler
(Interrupt
).Static
then
686 -- Tries to detach a static Interrupt Handler, raise program error
688 raise Program_Error
with
689 "trying to detach a static interrupt handler";
692 -- The interrupt should no longer be ignored if
693 -- it was ever ignored.
695 Ignored
(Interrupt
) := False;
699 User_Handler
(Interrupt
).H
:= null;
700 User_Handler
(Interrupt
).Static
:= False;
701 IMOP
.Interrupt_Self_Process
(IMNG
.Interrupt_ID
(Interrupt
));
703 end Unprotected_Detach_Handler
;
705 -- Start of processing for Interrupt_Manager
708 -- By making this task independent of master, when the process goes
709 -- away, the Interrupt_Manager will terminate gracefully.
711 System
.Tasking
.Utilities
.Make_Independent
;
713 -- Environment task gets its own interrupt mask, saves it, and then
714 -- masks all interrupts except the Keep_Unmasked set.
716 -- During rendezvous, the Interrupt_Manager receives the old interrupt
717 -- mask of the environment task, and sets its own interrupt mask to that
720 -- The environment task will call the entry of Interrupt_Manager some
721 -- during elaboration of the body of this package.
723 accept Initialize
(Mask
: IMNG
.Interrupt_Mask
) do
724 pragma Warnings
(Off
, Mask
);
728 -- Note: All tasks in RTS will have all the Reserve Interrupts being
729 -- masked (except the Interrupt_Manager) and Keep_Unmasked unmasked
732 -- Abort_Task_Interrupt is one of the Interrupt unmasked in all tasks.
733 -- We mask the Interrupt in this particular task so that "sigwait" is
734 -- possible to catch an explicitly sent Abort_Task_Interrupt from the
737 -- This sigwaiting is needed so that we make sure a Server_Task is out
738 -- of its own sigwait state. This extra synchronization is necessary to
739 -- prevent following scenarios.
741 -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to the
742 -- Server_Task then changes its own interrupt mask (OS level).
743 -- If an interrupt (corresponding to the Server_Task) arrives
744 -- in the mean time we have the Interrupt_Manager unmasked and
745 -- the Server_Task waiting on sigwait.
747 -- 2) For unbinding handler, we install a default action in the
748 -- Interrupt_Manager. POSIX.1c states that the result of using
749 -- "sigwait" and "sigaction" simultaneously on the same interrupt
750 -- is undefined. Therefore, we need to be informed from the
751 -- Server_Task of the fact that the Server_Task is out of its
755 -- A block is needed to absorb Program_Error exception
758 Old_Handler
: Parameterless_Handler
;
763 accept Attach_Handler
764 (New_Handler
: Parameterless_Handler
;
765 Interrupt
: Interrupt_ID
;
767 Restoration
: Boolean := False)
769 Unprotected_Exchange_Handler
770 (Old_Handler
, New_Handler
, Interrupt
, Static
, Restoration
);
773 or accept Exchange_Handler
774 (Old_Handler
: out Parameterless_Handler
;
775 New_Handler
: Parameterless_Handler
;
776 Interrupt
: Interrupt_ID
;
779 Unprotected_Exchange_Handler
780 (Old_Handler
, New_Handler
, Interrupt
, Static
);
781 end Exchange_Handler
;
783 or accept Detach_Handler
784 (Interrupt
: Interrupt_ID
;
787 Unprotected_Detach_Handler
(Interrupt
, Static
);
790 or accept Bind_Interrupt_To_Entry
792 E
: Task_Entry_Index
;
793 Interrupt
: Interrupt_ID
)
795 -- if there is a binding already (either a procedure or an
796 -- entry), raise Program_Error (propagate it to the caller).
798 if User_Handler
(Interrupt
).H
/= null
799 or else User_Entry
(Interrupt
).T
/= Null_Task
801 raise Program_Error
with
802 "a binding for this interrupt is already present";
805 -- The interrupt should no longer be ignored if
806 -- it was ever ignored.
808 Ignored
(Interrupt
) := False;
809 User_Entry
(Interrupt
) := Entry_Assoc
'(T => T, E => E);
811 -- Indicate the attachment of Interrupt Entry in ATCB.
812 -- This is need so that when an Interrupt Entry task
813 -- terminates the binding can be cleaned.
814 -- The call to unbinding must be
815 -- make by the task before it terminates.
817 T.Interrupt_Entry := True;
819 -- Invoke a corresponding Server_Task if not yet created.
820 -- Place Task_Id info in Server_ID array.
822 if Server_ID (Interrupt) = Null_Task then
824 Access_Hold := new Server_Task (Interrupt);
825 Server_ID (Interrupt) :=
826 To_System (Access_Hold.all'Identity);
828 POP.Wakeup (Server_ID (Interrupt),
829 Interrupt_Server_Idle_Sleep);
831 end Bind_Interrupt_To_Entry;
833 or accept Detach_Interrupt_Entries (T : Task_Id)
835 for J in Interrupt_ID'Range loop
836 if not Is_Reserved (J) then
837 if User_Entry (J).T = T then
839 -- The interrupt should no longer be ignored if
840 -- it was ever ignored.
842 Ignored (J) := False;
844 Entry_Assoc'(T
=> Null_Task
, E
=> Null_Task_Entry
);
845 IMOP
.Interrupt_Self_Process
(IMNG
.Interrupt_ID
(J
));
850 -- Indicate in ATCB that no Interrupt Entries are attached
852 T
.Interrupt_Entry
:= False;
853 end Detach_Interrupt_Entries
;
855 or accept Block_Interrupt
(Interrupt
: Interrupt_ID
) do
856 pragma Warnings
(Off
, Interrupt
);
860 or accept Unblock_Interrupt
(Interrupt
: Interrupt_ID
) do
861 pragma Warnings
(Off
, Interrupt
);
863 end Unblock_Interrupt
;
865 or accept Ignore_Interrupt
(Interrupt
: Interrupt_ID
) do
866 pragma Warnings
(Off
, Interrupt
);
868 end Ignore_Interrupt
;
870 or accept Unignore_Interrupt
(Interrupt
: Interrupt_ID
) do
871 pragma Warnings
(Off
, Interrupt
);
873 end Unignore_Interrupt
;
878 -- If there is a program error we just want to propagate it to the
879 -- caller and do not want to stop this task.
881 when Program_Error
=>
885 pragma Assert
(False);
889 end Interrupt_Manager
;
895 task body Server_Task
is
896 Self_ID
: constant Task_Id
:= Self
;
897 Tmp_Handler
: Parameterless_Handler
;
899 Tmp_Entry_Index
: Task_Entry_Index
;
900 Intwait_Mask
: aliased IMNG
.Interrupt_Mask
;
903 -- By making this task independent of master, when the process
904 -- goes away, the Server_Task will terminate gracefully.
906 System
.Tasking
.Utilities
.Make_Independent
;
908 -- Install default action in system level
910 IMOP
.Install_Default_Action
(IMNG
.Interrupt_ID
(Interrupt
));
912 -- Set up the mask (also clears the event flag)
914 IMOP
.Empty_Interrupt_Mask
(Intwait_Mask
'Access);
915 IMOP
.Add_To_Interrupt_Mask
916 (Intwait_Mask
'Access, IMNG
.Interrupt_ID
(Interrupt
));
918 -- Remember the Interrupt_ID for Abort_Task
920 PIO
.Set_Interrupt_ID
(IMNG
.Interrupt_ID
(Interrupt
), Self_ID
);
922 -- Note: All tasks in RTS will have all the Reserve Interrupts
923 -- being masked (except the Interrupt_Manager) and Keep_Unmasked
924 -- unmasked when created.
927 System
.Tasking
.Initialization
.Defer_Abort
(Self_ID
);
929 -- A Handler or an Entry is installed. At this point all tasks
930 -- mask for the Interrupt is masked. Catch the Interrupt using
933 -- This task may wake up from sigwait by receiving an interrupt
934 -- (Abort_Task_Interrupt) from the Interrupt_Manager for unbinding
935 -- a Procedure Handler or an Entry. Or it could be a wake up
936 -- from status change (Unblocked -> Blocked). If that is not
937 -- the case, we should execute the attached Procedure or Entry.
943 POP
.Write_Lock
(Self_ID
);
945 if User_Handler
(Interrupt
).H
= null
946 and then User_Entry
(Interrupt
).T
= Null_Task
948 -- No Interrupt binding. If there is an interrupt,
949 -- Interrupt_Manager will take default action.
951 Self_ID
.Common
.State
:= Interrupt_Server_Idle_Sleep
;
952 POP
.Sleep
(Self_ID
, Interrupt_Server_Idle_Sleep
);
953 Self_ID
.Common
.State
:= Runnable
;
956 Self_ID
.Common
.State
:= Interrupt_Server_Blocked_On_Event_Flag
;
957 Self_ID
.Common
.State
:= Runnable
;
959 if not (Self_ID
.Deferral_Level
= 0
960 and then Self_ID
.Pending_ATC_Level
961 < Self_ID
.ATC_Nesting_Level
)
963 if User_Handler
(Interrupt
).H
/= null then
964 Tmp_Handler
:= User_Handler
(Interrupt
).H
;
966 -- RTS calls should not be made with self being locked
968 POP
.Unlock
(Self_ID
);
980 POP
.Write_Lock
(Self_ID
);
982 elsif User_Entry
(Interrupt
).T
/= Null_Task
then
983 Tmp_ID
:= User_Entry
(Interrupt
).T
;
984 Tmp_Entry_Index
:= User_Entry
(Interrupt
).E
;
986 -- RTS calls should not be made with self being locked
988 POP
.Unlock
(Self_ID
);
994 System
.Tasking
.Rendezvous
.Call_Simple
995 (Tmp_ID
, Tmp_Entry_Index
, System
.Null_Address
);
1001 POP
.Write_Lock
(Self_ID
);
1006 POP
.Unlock
(Self_ID
);
1012 System
.Tasking
.Initialization
.Undefer_Abort
(Self_ID
);
1014 -- Undefer abort here to allow a window for this task
1015 -- to be aborted at the time of system shutdown.
1019 -------------------------------------
1020 -- Has_Interrupt_Or_Attach_Handler --
1021 -------------------------------------
1023 function Has_Interrupt_Or_Attach_Handler
1024 (Object
: access Dynamic_Interrupt_Protection
) return Boolean
1026 pragma Warnings
(Off
, Object
);
1029 end Has_Interrupt_Or_Attach_Handler
;
1035 procedure Finalize
(Object
: in out Static_Interrupt_Protection
) is
1037 -- ??? loop to be executed only when we're not doing library level
1038 -- finalization, since in this case all interrupt tasks are gone.
1040 if not Interrupt_Manager
'Terminated then
1041 for N
in reverse Object
.Previous_Handlers
'Range loop
1042 Interrupt_Manager
.Attach_Handler
1043 (New_Handler
=> Object
.Previous_Handlers
(N
).Handler
,
1044 Interrupt
=> Object
.Previous_Handlers
(N
).Interrupt
,
1045 Static
=> Object
.Previous_Handlers
(N
).Static
,
1046 Restoration
=> True);
1050 Tasking
.Protected_Objects
.Entries
.Finalize
1051 (Tasking
.Protected_Objects
.Entries
.Protection_Entries
(Object
));
1054 -------------------------------------
1055 -- Has_Interrupt_Or_Attach_Handler --
1056 -------------------------------------
1058 function Has_Interrupt_Or_Attach_Handler
1059 (Object
: access Static_Interrupt_Protection
) return Boolean
1061 pragma Warnings
(Off
, Object
);
1064 end Has_Interrupt_Or_Attach_Handler
;
1066 ----------------------
1067 -- Install_Handlers --
1068 ----------------------
1070 procedure Install_Handlers
1071 (Object
: access Static_Interrupt_Protection
;
1072 New_Handlers
: New_Handler_Array
)
1075 for N
in New_Handlers
'Range loop
1077 -- We need a lock around this ???
1079 Object
.Previous_Handlers
(N
).Interrupt
:= New_Handlers
(N
).Interrupt
;
1080 Object
.Previous_Handlers
(N
).Static
:= User_Handler
1081 (New_Handlers
(N
).Interrupt
).Static
;
1083 -- We call Exchange_Handler and not directly Interrupt_Manager.
1084 -- Exchange_Handler so we get the Is_Reserved check.
1087 (Old_Handler
=> Object
.Previous_Handlers
(N
).Handler
,
1088 New_Handler
=> New_Handlers
(N
).Handler
,
1089 Interrupt
=> New_Handlers
(N
).Interrupt
,
1092 end Install_Handlers
;
1094 ---------------------------------
1095 -- Install_Restricted_Handlers --
1096 ---------------------------------
1098 procedure Install_Restricted_Handlers
1099 (Prio
: Any_Priority
;
1100 Handlers
: New_Handler_Array
)
1102 pragma Unreferenced
(Prio
);
1104 for N
in Handlers
'Range loop
1105 Attach_Handler
(Handlers
(N
).Handler
, Handlers
(N
).Interrupt
, True);
1107 end Install_Restricted_Handlers
;
1109 -- Elaboration code for package System.Interrupts
1112 -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent
1114 Interrupt_Manager_ID
:= To_System
(Interrupt_Manager
'Identity);
1116 -- During the elaboration of this package body we want RTS to inherit the
1117 -- interrupt mask from the Environment Task.
1119 -- The Environment Task should have gotten its mask from the enclosing
1120 -- process during the RTS start up. (See in s-inmaop.adb). Pass the
1121 -- Interrupt_Mask of the Environment task to the Interrupt_Manager.
1123 -- Note : At this point we know that all tasks (including RTS internal
1124 -- servers) are masked for non-reserved signals (see s-taprop.adb). Only
1125 -- the Interrupt_Manager will have masks set up differently inheriting the
1126 -- original Environment Task's mask.
1128 Interrupt_Manager
.Initialize
(IMOP
.Environment_Mask
);
1129 end System
.Interrupts
;