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-2013, 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 ------------------------------------------------------------------------------
34 -- All user-handleable interrupts are masked at all times in all
35 -- tasks/threads except possibly for the Interrupt_Manager task.
37 -- When a user task wants to have the effect of masking/unmasking an
38 -- interrupt, it must call Block_Interrupt/Unblock_Interrupt, which
39 -- will have the effect of unmasking/masking the interrupt in the
40 -- Interrupt_Manager task.
42 -- Note : Direct calls to sigaction, sigprocmask, pthread_sigsetmask or any
43 -- other low-level interface that changes the interrupt action or
44 -- interrupt mask needs a careful thought.
45 -- One may achieve the effect of system calls first masking RTS blocked
46 -- (by calling Block_Interrupt) for the interrupt under consideration.
47 -- This will make all the tasks in RTS blocked for the Interrupt.
49 -- Once we associate a Server_Task with an interrupt, the task never
50 -- goes away, and we never remove the association.
52 -- There is no more than one interrupt per Server_Task and no more than
53 -- one Server_Task per interrupt.
55 with Ada
.Task_Identification
;
57 with System
.Task_Primitives
;
58 with System
.Interrupt_Management
;
60 with System
.Interrupt_Management
.Operations
;
61 pragma Elaborate_All
(System
.Interrupt_Management
.Operations
);
63 with System
.Task_Primitives
.Operations
;
64 with System
.Task_Primitives
.Interrupt_Operations
;
65 with System
.Storage_Elements
;
66 with System
.Tasking
.Utilities
;
68 with System
.Tasking
.Rendezvous
;
69 pragma Elaborate_All
(System
.Tasking
.Rendezvous
);
71 with System
.Tasking
.Initialization
;
72 with System
.Parameters
;
74 with Ada
.Unchecked_Conversion
;
76 package body System
.Interrupts
is
81 package POP
renames System
.Task_Primitives
.Operations
;
82 package PIO
renames System
.Task_Primitives
.Interrupt_Operations
;
83 package IMNG
renames System
.Interrupt_Management
;
84 package IMOP
renames System
.Interrupt_Management
.Operations
;
86 function To_System
is new Ada
.Unchecked_Conversion
87 (Ada
.Task_Identification
.Task_Id
, Task_Id
);
93 -- WARNING: System.Tasking.Stages performs calls to this task with
94 -- low-level constructs. Do not change this spec without synchronizing it.
96 task Interrupt_Manager
is
97 entry Detach_Interrupt_Entries
(T
: Task_Id
);
99 entry Initialize
(Mask
: IMNG
.Interrupt_Mask
);
102 (New_Handler
: Parameterless_Handler
;
103 Interrupt
: Interrupt_ID
;
105 Restoration
: Boolean := False);
107 entry Exchange_Handler
108 (Old_Handler
: out Parameterless_Handler
;
109 New_Handler
: Parameterless_Handler
;
110 Interrupt
: Interrupt_ID
;
114 (Interrupt
: Interrupt_ID
;
117 entry Bind_Interrupt_To_Entry
119 E
: Task_Entry_Index
;
120 Interrupt
: Interrupt_ID
);
122 entry Block_Interrupt
(Interrupt
: Interrupt_ID
);
124 entry Unblock_Interrupt
(Interrupt
: Interrupt_ID
);
126 entry Ignore_Interrupt
(Interrupt
: Interrupt_ID
);
128 entry Unignore_Interrupt
(Interrupt
: Interrupt_ID
);
130 pragma Interrupt_Priority
(System
.Interrupt_Priority
'Last);
131 end Interrupt_Manager
;
133 task type Server_Task
(Interrupt
: Interrupt_ID
) is
134 pragma Priority
(System
.Interrupt_Priority
'Last);
135 -- Note: the above pragma Priority is strictly speaking improper since
136 -- it is outside the range of allowed priorities, but the compiler
137 -- treats system units specially and does not apply this range checking
138 -- rule to system units.
142 type Server_Task_Access
is access Server_Task
;
144 -------------------------------
145 -- Local Types and Variables --
146 -------------------------------
148 type Entry_Assoc
is record
150 E
: Task_Entry_Index
;
153 type Handler_Assoc
is record
154 H
: Parameterless_Handler
;
155 Static
: Boolean; -- Indicates static binding;
158 User_Handler
: array (Interrupt_ID
'Range) of Handler_Assoc
:=
159 (others => (null, Static
=> False));
160 pragma Volatile_Components
(User_Handler
);
161 -- Holds the protected procedure handler (if any) and its Static
162 -- information for each interrupt. A handler is a Static one if it is
163 -- specified through the pragma Attach_Handler. Attach_Handler. Otherwise,
166 User_Entry
: array (Interrupt_ID
'Range) of Entry_Assoc
:=
167 (others => (T
=> Null_Task
, E
=> Null_Task_Entry
));
168 pragma Volatile_Components
(User_Entry
);
169 -- Holds the task and entry index (if any) for each interrupt
171 Blocked
: array (Interrupt_ID
'Range) of Boolean := (others => False);
172 pragma Atomic_Components
(Blocked
);
173 -- True iff the corresponding interrupt is blocked in the process level
175 Ignored
: array (Interrupt_ID
'Range) of Boolean := (others => False);
176 pragma Atomic_Components
(Ignored
);
177 -- True iff the corresponding interrupt is blocked in the process level
180 array (Interrupt_ID
'Range) of Task_Id
:= (others => Null_Task
);
181 pragma Atomic_Components
(Last_Unblocker
);
182 -- Holds the ID of the last Task which Unblocked this Interrupt. It
183 -- contains Null_Task if no tasks have ever requested the Unblocking
184 -- operation or the Interrupt is currently Blocked.
186 Server_ID
: array (Interrupt_ID
'Range) of Task_Id
:=
187 (others => Null_Task
);
188 pragma Atomic_Components
(Server_ID
);
189 -- Holds the Task_Id of the Server_Task for each interrupt. Task_Id is
190 -- needed to accomplish locking per Interrupt base. Also is needed to
191 -- decide whether to create a new Server_Task.
193 -- Type and Head, Tail of the list containing Registered Interrupt
194 -- Handlers. These definitions are used to register the handlers
195 -- specified by the pragma Interrupt_Handler.
197 type Registered_Handler
;
198 type R_Link
is access all Registered_Handler
;
200 type Registered_Handler
is record
201 H
: System
.Address
:= System
.Null_Address
;
202 Next
: R_Link
:= null;
205 Registered_Handler_Head
: R_Link
:= null;
206 Registered_Handler_Tail
: R_Link
:= null;
208 Access_Hold
: Server_Task_Access
;
209 -- Variable used to allocate Server_Task using "new"
211 -----------------------
212 -- Local Subprograms --
213 -----------------------
215 function Is_Registered
(Handler
: Parameterless_Handler
) return Boolean;
216 -- See if the Handler has been "pragma"ed using Interrupt_Handler. Always
217 -- consider a null handler as registered.
223 -- Calling this procedure with New_Handler = null and Static = True means
224 -- we want to detach the current handler regardless of the previous
225 -- handler's binding status (i.e. do not care if it is a dynamic or static
228 -- This option is needed so that during the finalization of a PO, we can
229 -- detach handlers attached through pragma Attach_Handler.
231 procedure Attach_Handler
232 (New_Handler
: Parameterless_Handler
;
233 Interrupt
: Interrupt_ID
;
234 Static
: Boolean := False)
237 if Is_Reserved
(Interrupt
) then
238 raise Program_Error
with
239 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
242 Interrupt_Manager
.Attach_Handler
(New_Handler
, Interrupt
, Static
);
246 -----------------------------
247 -- Bind_Interrupt_To_Entry --
248 -----------------------------
250 -- This procedure raises a Program_Error if it tries to bind an interrupt
251 -- to which an Entry or a Procedure is already bound.
253 procedure Bind_Interrupt_To_Entry
255 E
: Task_Entry_Index
;
256 Int_Ref
: System
.Address
)
258 Interrupt
: constant Interrupt_ID
:=
259 Interrupt_ID
(Storage_Elements
.To_Integer
(Int_Ref
));
262 if Is_Reserved
(Interrupt
) then
263 raise Program_Error
with
264 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
267 Interrupt_Manager
.Bind_Interrupt_To_Entry
(T
, E
, Interrupt
);
268 end Bind_Interrupt_To_Entry
;
270 ---------------------
271 -- Block_Interrupt --
272 ---------------------
274 procedure Block_Interrupt
(Interrupt
: Interrupt_ID
) is
276 if Is_Reserved
(Interrupt
) then
277 raise Program_Error
with
278 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
281 Interrupt_Manager
.Block_Interrupt
(Interrupt
);
284 ---------------------
285 -- Current_Handler --
286 ---------------------
288 function Current_Handler
289 (Interrupt
: Interrupt_ID
) return Parameterless_Handler
292 if Is_Reserved
(Interrupt
) then
293 raise Program_Error
with
294 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
297 -- ??? Since Parameterless_Handler is not Atomic, the current
298 -- implementation is wrong. We need a new service in Interrupt_Manager
299 -- to ensure atomicity.
301 return User_Handler
(Interrupt
).H
;
308 -- Calling this procedure with Static = True means we want to Detach the
309 -- current handler regardless of the previous handler's binding status
310 -- (i.e. do not care if it is a dynamic or static handler).
312 -- This option is needed so that during the finalization of a PO, we can
313 -- detach handlers attached through pragma Attach_Handler.
315 procedure Detach_Handler
316 (Interrupt
: Interrupt_ID
;
317 Static
: Boolean := False)
320 if Is_Reserved
(Interrupt
) then
321 raise Program_Error
with
322 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
325 Interrupt_Manager
.Detach_Handler
(Interrupt
, Static
);
328 ------------------------------
329 -- Detach_Interrupt_Entries --
330 ------------------------------
332 procedure Detach_Interrupt_Entries
(T
: Task_Id
) is
334 Interrupt_Manager
.Detach_Interrupt_Entries
(T
);
335 end Detach_Interrupt_Entries
;
337 ----------------------
338 -- Exchange_Handler --
339 ----------------------
341 -- Calling this procedure with New_Handler = null and Static = True means
342 -- we want to detach the current handler regardless of the previous
343 -- handler's binding status (i.e. do not care if it is a dynamic or static
346 -- This option is needed so that during the finalization of a PO, we can
347 -- detach handlers attached through pragma Attach_Handler.
349 procedure Exchange_Handler
350 (Old_Handler
: out Parameterless_Handler
;
351 New_Handler
: Parameterless_Handler
;
352 Interrupt
: Interrupt_ID
;
353 Static
: Boolean := False)
356 if Is_Reserved
(Interrupt
) then
357 raise Program_Error
with
358 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
361 Interrupt_Manager
.Exchange_Handler
362 (Old_Handler
, New_Handler
, Interrupt
, Static
);
363 end Exchange_Handler
;
369 procedure Finalize
(Object
: in out Static_Interrupt_Protection
) is
371 (Int
: System
.Interrupt_Management
.Interrupt_ID
) return Character;
372 pragma Import
(C
, State
, "__gnat_get_interrupt_state");
373 -- Get interrupt state for interrupt number Int. Defined in init.c
375 Default
: constant Character := 's';
376 -- 's' Interrupt_State pragma set state to System (use "default"
380 -- ??? loop to be executed only when we're not doing library level
381 -- finalization, since in this case all interrupt tasks are gone.
383 -- If the Abort_Task signal is set to system, it means that we cannot
384 -- reset interrupt handlers since this would require sending the abort
385 -- signal to the Server_Task
387 if not Interrupt_Manager
'Terminated
388 and then State
(System
.Interrupt_Management
.Abort_Task_Interrupt
)
391 for N
in reverse Object
.Previous_Handlers
'Range loop
392 Interrupt_Manager
.Attach_Handler
393 (New_Handler
=> Object
.Previous_Handlers
(N
).Handler
,
394 Interrupt
=> Object
.Previous_Handlers
(N
).Interrupt
,
395 Static
=> Object
.Previous_Handlers
(N
).Static
,
396 Restoration
=> True);
400 Tasking
.Protected_Objects
.Entries
.Finalize
401 (Tasking
.Protected_Objects
.Entries
.Protection_Entries
(Object
));
404 -------------------------------------
405 -- Has_Interrupt_Or_Attach_Handler --
406 -------------------------------------
408 -- Need comments as to why these always return True ???
410 function Has_Interrupt_Or_Attach_Handler
411 (Object
: access Dynamic_Interrupt_Protection
) return Boolean
413 pragma Unreferenced
(Object
);
416 end Has_Interrupt_Or_Attach_Handler
;
418 function Has_Interrupt_Or_Attach_Handler
419 (Object
: access Static_Interrupt_Protection
) return Boolean
421 pragma Unreferenced
(Object
);
424 end Has_Interrupt_Or_Attach_Handler
;
426 ----------------------
427 -- Ignore_Interrupt --
428 ----------------------
430 procedure Ignore_Interrupt
(Interrupt
: Interrupt_ID
) is
432 if Is_Reserved
(Interrupt
) then
433 raise Program_Error
with
434 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
437 Interrupt_Manager
.Ignore_Interrupt
(Interrupt
);
438 end Ignore_Interrupt
;
440 ----------------------
441 -- Install_Handlers --
442 ----------------------
444 procedure Install_Handlers
445 (Object
: access Static_Interrupt_Protection
;
446 New_Handlers
: New_Handler_Array
)
449 for N
in New_Handlers
'Range loop
451 -- We need a lock around this ???
453 Object
.Previous_Handlers
(N
).Interrupt
:= New_Handlers
(N
).Interrupt
;
454 Object
.Previous_Handlers
(N
).Static
:= User_Handler
455 (New_Handlers
(N
).Interrupt
).Static
;
457 -- We call Exchange_Handler and not directly Interrupt_Manager.
458 -- Exchange_Handler so we get the Is_Reserved check.
461 (Old_Handler
=> Object
.Previous_Handlers
(N
).Handler
,
462 New_Handler
=> New_Handlers
(N
).Handler
,
463 Interrupt
=> New_Handlers
(N
).Interrupt
,
466 end Install_Handlers
;
468 ---------------------------------
469 -- Install_Restricted_Handlers --
470 ---------------------------------
472 procedure Install_Restricted_Handlers
473 (Prio
: Any_Priority
;
474 Handlers
: New_Handler_Array
)
476 pragma Unreferenced
(Prio
);
478 for N
in Handlers
'Range loop
479 Attach_Handler
(Handlers
(N
).Handler
, Handlers
(N
).Interrupt
, True);
481 end Install_Restricted_Handlers
;
487 function Is_Blocked
(Interrupt
: Interrupt_ID
) return Boolean is
489 if Is_Reserved
(Interrupt
) then
490 raise Program_Error
with
491 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
494 return Blocked
(Interrupt
);
497 -----------------------
498 -- Is_Entry_Attached --
499 -----------------------
501 function Is_Entry_Attached
(Interrupt
: Interrupt_ID
) return Boolean is
503 if Is_Reserved
(Interrupt
) then
504 raise Program_Error
with
505 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
508 return User_Entry
(Interrupt
).T
/= Null_Task
;
509 end Is_Entry_Attached
;
511 -------------------------
512 -- Is_Handler_Attached --
513 -------------------------
515 function Is_Handler_Attached
(Interrupt
: Interrupt_ID
) return Boolean is
517 if Is_Reserved
(Interrupt
) then
518 raise Program_Error
with
519 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
522 return User_Handler
(Interrupt
).H
/= null;
523 end Is_Handler_Attached
;
529 function Is_Ignored
(Interrupt
: Interrupt_ID
) return Boolean is
531 if Is_Reserved
(Interrupt
) then
532 raise Program_Error
with
533 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
536 return Ignored
(Interrupt
);
543 function Is_Registered
(Handler
: Parameterless_Handler
) return Boolean is
545 type Fat_Ptr
is record
546 Object_Addr
: System
.Address
;
547 Handler_Addr
: System
.Address
;
550 function To_Fat_Ptr
is new Ada
.Unchecked_Conversion
551 (Parameterless_Handler
, Fat_Ptr
);
557 if Handler
= null then
561 Fat
:= To_Fat_Ptr
(Handler
);
563 Ptr
:= Registered_Handler_Head
;
565 while Ptr
/= null loop
566 if Ptr
.H
= Fat
.Handler_Addr
then
580 function Is_Reserved
(Interrupt
: Interrupt_ID
) return Boolean is
582 return IMNG
.Reserve
(IMNG
.Interrupt_ID
(Interrupt
));
589 function Reference
(Interrupt
: Interrupt_ID
) return System
.Address
is
591 if Is_Reserved
(Interrupt
) then
592 raise Program_Error
with
593 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
596 return Storage_Elements
.To_Address
597 (Storage_Elements
.Integer_Address
(Interrupt
));
600 ---------------------------------
601 -- Register_Interrupt_Handler --
602 ---------------------------------
604 procedure Register_Interrupt_Handler
(Handler_Addr
: System
.Address
) is
605 New_Node_Ptr
: R_Link
;
608 -- This routine registers the Handler as usable for Dynamic Interrupt
609 -- Handler. Routines attaching and detaching Handler dynamically should
610 -- first consult if the Handler is registered. A Program Error should
611 -- be raised if it is not registered.
613 -- The pragma Interrupt_Handler can only appear in the library level PO
614 -- definition and instantiation. Therefore, we do not need to implement
615 -- Unregistering operation. Neither we need to protect the queue
616 -- structure using a Lock.
618 pragma Assert
(Handler_Addr
/= System
.Null_Address
);
620 New_Node_Ptr
:= new Registered_Handler
;
621 New_Node_Ptr
.H
:= Handler_Addr
;
623 if Registered_Handler_Head
= null then
624 Registered_Handler_Head
:= New_Node_Ptr
;
625 Registered_Handler_Tail
:= New_Node_Ptr
;
628 Registered_Handler_Tail
.Next
:= New_Node_Ptr
;
629 Registered_Handler_Tail
:= New_Node_Ptr
;
631 end Register_Interrupt_Handler
;
633 -----------------------
634 -- Unblock_Interrupt --
635 -----------------------
637 procedure Unblock_Interrupt
(Interrupt
: Interrupt_ID
) is
639 if Is_Reserved
(Interrupt
) then
640 raise Program_Error
with
641 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
644 Interrupt_Manager
.Unblock_Interrupt
(Interrupt
);
645 end Unblock_Interrupt
;
651 function Unblocked_By
652 (Interrupt
: Interrupt_ID
) return System
.Tasking
.Task_Id
655 if Is_Reserved
(Interrupt
) then
656 raise Program_Error
with
657 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
660 return Last_Unblocker
(Interrupt
);
663 ------------------------
664 -- Unignore_Interrupt --
665 ------------------------
667 procedure Unignore_Interrupt
(Interrupt
: Interrupt_ID
) is
669 if Is_Reserved
(Interrupt
) then
670 raise Program_Error
with
671 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
674 Interrupt_Manager
.Unignore_Interrupt
(Interrupt
);
675 end Unignore_Interrupt
;
677 -----------------------
678 -- Interrupt_Manager --
679 -----------------------
681 task body Interrupt_Manager
is
683 ---------------------
684 -- Local Variables --
685 ---------------------
687 Intwait_Mask
: aliased IMNG
.Interrupt_Mask
;
688 Ret_Interrupt
: Interrupt_ID
;
689 Old_Mask
: aliased IMNG
.Interrupt_Mask
;
690 Old_Handler
: Parameterless_Handler
;
696 procedure Bind_Handler
(Interrupt
: Interrupt_ID
);
697 -- This procedure does not do anything if the Interrupt is blocked.
698 -- Otherwise, we have to interrupt Server_Task for status change through
701 procedure Unbind_Handler
(Interrupt
: Interrupt_ID
);
702 -- This procedure does not do anything if the Interrupt is blocked.
703 -- Otherwise, we have to interrupt Server_Task for status change
704 -- through abort interrupt.
706 procedure Unprotected_Exchange_Handler
707 (Old_Handler
: out Parameterless_Handler
;
708 New_Handler
: Parameterless_Handler
;
709 Interrupt
: Interrupt_ID
;
711 Restoration
: Boolean := False);
713 procedure Unprotected_Detach_Handler
714 (Interrupt
: Interrupt_ID
;
721 procedure Bind_Handler
(Interrupt
: Interrupt_ID
) is
723 if not Blocked
(Interrupt
) then
725 -- Mask this task for the given Interrupt so that all tasks
726 -- are masked for the Interrupt and the actual delivery of the
727 -- Interrupt will be caught using "sigwait" by the
728 -- corresponding Server_Task.
730 IMOP
.Thread_Block_Interrupt
(IMNG
.Interrupt_ID
(Interrupt
));
732 -- We have installed a Handler or an Entry before we called
733 -- this procedure. If the Handler Task is waiting to be awakened,
734 -- do it here. Otherwise, the interrupt will be discarded.
736 POP
.Wakeup
(Server_ID
(Interrupt
), Interrupt_Server_Idle_Sleep
);
744 procedure Unbind_Handler
(Interrupt
: Interrupt_ID
) is
745 Server
: System
.Tasking
.Task_Id
;
747 if not Blocked
(Interrupt
) then
748 -- Currently, there is a Handler or an Entry attached and
749 -- corresponding Server_Task is waiting on "sigwait."
750 -- We have to wake up the Server_Task and make it
751 -- wait on condition variable by sending an
752 -- Abort_Task_Interrupt
754 Server
:= Server_ID
(Interrupt
);
756 case Server
.Common
.State
is
757 when Interrupt_Server_Idle_Sleep |
758 Interrupt_Server_Blocked_Interrupt_Sleep
760 POP
.Wakeup
(Server
, Server
.Common
.State
);
762 when Interrupt_Server_Blocked_On_Event_Flag
=>
763 POP
.Abort_Task
(Server
);
765 -- Make sure corresponding Server_Task is out of its
766 -- own sigwait state.
769 Interrupt_ID
(IMOP
.Interrupt_Wait
(Intwait_Mask
'Access));
771 (Ret_Interrupt
= Interrupt_ID
(IMNG
.Abort_Task_Interrupt
));
777 pragma Assert
(False);
781 IMOP
.Install_Default_Action
(IMNG
.Interrupt_ID
(Interrupt
));
783 -- Unmake the Interrupt for this task in order to allow default
786 IMOP
.Thread_Unblock_Interrupt
(IMNG
.Interrupt_ID
(Interrupt
));
789 IMOP
.Install_Default_Action
(IMNG
.Interrupt_ID
(Interrupt
));
793 --------------------------------
794 -- Unprotected_Detach_Handler --
795 --------------------------------
797 procedure Unprotected_Detach_Handler
798 (Interrupt
: Interrupt_ID
;
801 Old_Handler
: Parameterless_Handler
;
804 if User_Entry
(Interrupt
).T
/= Null_Task
then
806 -- In case we have an Interrupt Entry installed.
807 -- raise a program error. (propagate it to the caller).
809 raise Program_Error
with
810 "An interrupt entry is already installed";
813 -- Note : Static = True will pass the following check. That is the
814 -- case when we want to detach a handler regardless of the static
815 -- status of the current_Handler.
817 if not Static
and then User_Handler
(Interrupt
).Static
then
819 -- Tries to detach a static Interrupt Handler.
820 -- raise a program error.
822 raise Program_Error
with
823 "Trying to detach a static Interrupt Handler";
826 -- The interrupt should no longer be ignored if
827 -- it was ever ignored.
829 Ignored
(Interrupt
) := False;
831 Old_Handler
:= User_Handler
(Interrupt
).H
;
835 User_Handler
(Interrupt
).H
:= null;
836 User_Handler
(Interrupt
).Static
:= False;
838 if Old_Handler
/= null then
839 Unbind_Handler
(Interrupt
);
841 end Unprotected_Detach_Handler
;
843 ----------------------------------
844 -- Unprotected_Exchange_Handler --
845 ----------------------------------
847 procedure Unprotected_Exchange_Handler
848 (Old_Handler
: out Parameterless_Handler
;
849 New_Handler
: Parameterless_Handler
;
850 Interrupt
: Interrupt_ID
;
852 Restoration
: Boolean := False)
855 if User_Entry
(Interrupt
).T
/= Null_Task
then
857 -- In case we have an Interrupt Entry already installed.
858 -- raise a program error. (propagate it to the caller).
860 raise Program_Error
with
861 "An interrupt is already installed";
864 -- Note : A null handler with Static = True will pass the
865 -- following check. That is the case when we want to Detach a
866 -- handler regardless of the Static status of the current_Handler.
868 -- We don't check anything if Restoration is True, since we
869 -- may be detaching a static handler to restore a dynamic one.
871 if not Restoration
and then not Static
873 -- Tries to overwrite a static Interrupt Handler with a
876 and then (User_Handler
(Interrupt
).Static
878 -- The new handler is not specified as an
879 -- Interrupt Handler by a pragma.
881 or else not Is_Registered
(New_Handler
))
883 raise Program_Error
with
884 "Trying to overwrite a static Interrupt Handler with a " &
888 -- The interrupt should no longer be ignored if
889 -- it was ever ignored.
891 Ignored
(Interrupt
) := False;
893 -- Save the old handler
895 Old_Handler
:= User_Handler
(Interrupt
).H
;
899 User_Handler
(Interrupt
).H
:= New_Handler
;
901 if New_Handler
= null then
903 -- The null handler means we are detaching the handler
905 User_Handler
(Interrupt
).Static
:= False;
908 User_Handler
(Interrupt
).Static
:= Static
;
911 -- Invoke a corresponding Server_Task if not yet created.
912 -- Place Task_Id info in Server_ID array.
914 if Server_ID
(Interrupt
) = Null_Task
then
916 -- When a new Server_Task is created, it should have its
917 -- signal mask set to the All_Tasks_Mask.
919 IMOP
.Set_Interrupt_Mask
920 (IMOP
.All_Tasks_Mask
'Access, Old_Mask
'Access);
921 Access_Hold
:= new Server_Task
(Interrupt
);
922 IMOP
.Set_Interrupt_Mask
(Old_Mask
'Access);
924 Server_ID
(Interrupt
) := To_System
(Access_Hold
.all'Identity);
927 if New_Handler
= null then
928 if Old_Handler
/= null then
929 Unbind_Handler
(Interrupt
);
935 if Old_Handler
= null then
936 Bind_Handler
(Interrupt
);
938 end Unprotected_Exchange_Handler
;
940 -- Start of processing for Interrupt_Manager
943 -- By making this task independent of master, when the process
944 -- goes away, the Interrupt_Manager will terminate gracefully.
946 System
.Tasking
.Utilities
.Make_Independent
;
948 -- Environment task gets its own interrupt mask, saves it,
949 -- and then masks all interrupts except the Keep_Unmasked set.
951 -- During rendezvous, the Interrupt_Manager receives the old
952 -- interrupt mask of the environment task, and sets its own
953 -- interrupt mask to that value.
955 -- The environment task will call the entry of Interrupt_Manager some
956 -- during elaboration of the body of this package.
958 accept Initialize
(Mask
: IMNG
.Interrupt_Mask
) do
960 The_Mask
: aliased IMNG
.Interrupt_Mask
;
963 IMOP
.Copy_Interrupt_Mask
(The_Mask
, Mask
);
964 IMOP
.Set_Interrupt_Mask
(The_Mask
'Access);
968 -- Note: All tasks in RTS will have all the Reserve Interrupts
969 -- being masked (except the Interrupt_Manager) and Keep_Unmasked
970 -- unmasked when created.
972 -- Abort_Task_Interrupt is one of the Interrupt unmasked
973 -- in all tasks. We mask the Interrupt in this particular task
974 -- so that "sigwait" is possible to catch an explicitly sent
975 -- Abort_Task_Interrupt from the Server_Tasks.
977 -- This sigwaiting is needed so that we make sure a Server_Task is
978 -- out of its own sigwait state. This extra synchronization is
979 -- necessary to prevent following scenarios.
981 -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to the
982 -- Server_Task then changes its own interrupt mask (OS level).
983 -- If an interrupt (corresponding to the Server_Task) arrives
984 -- in the mean time we have the Interrupt_Manager unmasked and
985 -- the Server_Task waiting on sigwait.
987 -- 2) For unbinding handler, we install a default action in the
988 -- Interrupt_Manager. POSIX.1c states that the result of using
989 -- "sigwait" and "sigaction" simultaneously on the same interrupt
990 -- is undefined. Therefore, we need to be informed from the
991 -- Server_Task of the fact that the Server_Task is out of its
994 IMOP
.Empty_Interrupt_Mask
(Intwait_Mask
'Access);
995 IMOP
.Add_To_Interrupt_Mask
996 (Intwait_Mask
'Access, IMNG
.Abort_Task_Interrupt
);
997 IMOP
.Thread_Block_Interrupt
998 (IMNG
.Abort_Task_Interrupt
);
1001 -- A block is needed to absorb Program_Error exception
1005 accept Attach_Handler
1006 (New_Handler
: Parameterless_Handler
;
1007 Interrupt
: Interrupt_ID
;
1009 Restoration
: Boolean := False)
1011 Unprotected_Exchange_Handler
1012 (Old_Handler
, New_Handler
, Interrupt
, Static
, Restoration
);
1016 accept Exchange_Handler
1017 (Old_Handler
: out Parameterless_Handler
;
1018 New_Handler
: Parameterless_Handler
;
1019 Interrupt
: Interrupt_ID
;
1022 Unprotected_Exchange_Handler
1023 (Old_Handler
, New_Handler
, Interrupt
, Static
);
1024 end Exchange_Handler
;
1027 accept Detach_Handler
1028 (Interrupt
: Interrupt_ID
;
1031 Unprotected_Detach_Handler
(Interrupt
, Static
);
1035 accept Bind_Interrupt_To_Entry
1037 E
: Task_Entry_Index
;
1038 Interrupt
: Interrupt_ID
)
1040 -- if there is a binding already (either a procedure or an
1041 -- entry), raise Program_Error (propagate it to the caller).
1043 if User_Handler
(Interrupt
).H
/= null
1044 or else User_Entry
(Interrupt
).T
/= Null_Task
1046 raise Program_Error
with
1047 "A binding for this interrupt is already present";
1050 -- The interrupt should no longer be ignored if
1051 -- it was ever ignored.
1053 Ignored
(Interrupt
) := False;
1054 User_Entry
(Interrupt
) := Entry_Assoc
'(T => T, E => E);
1056 -- Indicate the attachment of Interrupt Entry in ATCB.
1057 -- This is need so that when an Interrupt Entry task
1058 -- terminates the binding can be cleaned. The call to
1059 -- unbinding must be made by the task before it terminates.
1061 T.Interrupt_Entry := True;
1063 -- Invoke a corresponding Server_Task if not yet created.
1064 -- Place Task_Id info in Server_ID array.
1066 if Server_ID (Interrupt) = Null_Task then
1068 -- When a new Server_Task is created, it should have its
1069 -- signal mask set to the All_Tasks_Mask.
1071 IMOP.Set_Interrupt_Mask
1072 (IMOP.All_Tasks_Mask'Access, Old_Mask'Access);
1073 Access_Hold := new Server_Task (Interrupt);
1074 IMOP.Set_Interrupt_Mask (Old_Mask'Access);
1075 Server_ID (Interrupt) :=
1076 To_System (Access_Hold.all'Identity);
1079 Bind_Handler (Interrupt);
1080 end Bind_Interrupt_To_Entry;
1083 accept Detach_Interrupt_Entries (T : Task_Id) do
1084 for J in Interrupt_ID'Range loop
1085 if not Is_Reserved (J) then
1086 if User_Entry (J).T = T then
1088 -- The interrupt should no longer be ignored if
1089 -- it was ever ignored.
1091 Ignored (J) := False;
1092 User_Entry (J) := Entry_Assoc'
1093 (T
=> Null_Task
, E
=> Null_Task_Entry
);
1099 -- Indicate in ATCB that no Interrupt Entries are attached
1101 T
.Interrupt_Entry
:= False;
1102 end Detach_Interrupt_Entries
;
1105 accept Block_Interrupt
(Interrupt
: Interrupt_ID
) do
1106 if Blocked
(Interrupt
) then
1110 Blocked
(Interrupt
) := True;
1111 Last_Unblocker
(Interrupt
) := Null_Task
;
1113 -- Mask this task for the given Interrupt so that all tasks
1114 -- are masked for the Interrupt.
1116 IMOP
.Thread_Block_Interrupt
(IMNG
.Interrupt_ID
(Interrupt
));
1118 if User_Handler
(Interrupt
).H
/= null
1119 or else User_Entry
(Interrupt
).T
/= Null_Task
1121 -- This is the case where the Server_Task is waiting
1122 -- on "sigwait." Wake it up by sending an
1123 -- Abort_Task_Interrupt so that the Server_Task
1126 POP
.Abort_Task
(Server_ID
(Interrupt
));
1128 -- Make sure corresponding Server_Task is out of its own
1131 Ret_Interrupt
:= Interrupt_ID
1132 (IMOP
.Interrupt_Wait
(Intwait_Mask
'Access));
1135 Interrupt_ID
(IMNG
.Abort_Task_Interrupt
));
1137 end Block_Interrupt
;
1140 accept Unblock_Interrupt
(Interrupt
: Interrupt_ID
) do
1141 if not Blocked
(Interrupt
) then
1145 Blocked
(Interrupt
) := False;
1146 Last_Unblocker
(Interrupt
) :=
1147 To_System
(Unblock_Interrupt
'Caller);
1149 if User_Handler
(Interrupt
).H
= null
1150 and then User_Entry
(Interrupt
).T
= Null_Task
1152 -- No handler is attached. Unmask the Interrupt so that
1153 -- the default action can be carried out.
1155 IMOP
.Thread_Unblock_Interrupt
1156 (IMNG
.Interrupt_ID
(Interrupt
));
1159 -- The Server_Task must be waiting on the Cond variable
1160 -- since it was being blocked and an Interrupt Hander or
1161 -- an Entry was there. Wake it up and let it change
1162 -- it place of waiting according to its new state.
1164 POP
.Wakeup
(Server_ID
(Interrupt
),
1165 Interrupt_Server_Blocked_Interrupt_Sleep
);
1167 end Unblock_Interrupt
;
1170 accept Ignore_Interrupt
(Interrupt
: Interrupt_ID
) do
1171 if Ignored
(Interrupt
) then
1175 Ignored
(Interrupt
) := True;
1177 -- If there is a handler associated with the Interrupt,
1178 -- detach it first. In this way we make sure that the
1179 -- Server_Task is not on sigwait. This is legal since
1180 -- Unignore_Interrupt is to install the default action.
1182 if User_Handler
(Interrupt
).H
/= null then
1183 Unprotected_Detach_Handler
1184 (Interrupt
=> Interrupt
, Static
=> True);
1186 elsif User_Entry
(Interrupt
).T
/= Null_Task
then
1187 User_Entry
(Interrupt
) := Entry_Assoc
'
1188 (T => Null_Task, E => Null_Task_Entry);
1189 Unbind_Handler (Interrupt);
1192 IMOP.Install_Ignore_Action (IMNG.Interrupt_ID (Interrupt));
1193 end Ignore_Interrupt;
1196 accept Unignore_Interrupt (Interrupt : Interrupt_ID) do
1197 Ignored (Interrupt) := False;
1199 -- If there is a handler associated with the Interrupt,
1200 -- detach it first. In this way we make sure that the
1201 -- Server_Task is not on sigwait. This is legal since
1202 -- Unignore_Interrupt is to install the default action.
1204 if User_Handler (Interrupt).H /= null then
1205 Unprotected_Detach_Handler
1206 (Interrupt => Interrupt, Static => True);
1208 elsif User_Entry (Interrupt).T /= Null_Task then
1209 User_Entry (Interrupt) := Entry_Assoc'
1210 (T
=> Null_Task
, E
=> Null_Task_Entry
);
1211 Unbind_Handler
(Interrupt
);
1214 IMOP
.Install_Default_Action
(IMNG
.Interrupt_ID
(Interrupt
));
1215 end Unignore_Interrupt
;
1219 -- If there is a program error we just want to propagate it to
1220 -- the caller and do not want to stop this task.
1222 when Program_Error
=>
1226 pragma Assert
(False);
1230 end Interrupt_Manager
;
1236 task body Server_Task
is
1237 Intwait_Mask
: aliased IMNG
.Interrupt_Mask
;
1238 Ret_Interrupt
: Interrupt_ID
;
1239 Self_ID
: constant Task_Id
:= Self
;
1240 Tmp_Handler
: Parameterless_Handler
;
1242 Tmp_Entry_Index
: Task_Entry_Index
;
1245 -- By making this task independent of master, when the process
1246 -- goes away, the Server_Task will terminate gracefully.
1248 System
.Tasking
.Utilities
.Make_Independent
;
1250 -- Install default action in system level
1252 IMOP
.Install_Default_Action
(IMNG
.Interrupt_ID
(Interrupt
));
1254 -- Note: All tasks in RTS will have all the Reserve Interrupts being
1255 -- masked (except the Interrupt_Manager) and Keep_Unmasked unmasked when
1258 -- Abort_Task_Interrupt is one of the Interrupt unmasked in all tasks.
1259 -- We mask the Interrupt in this particular task so that "sigwait" is
1260 -- possible to catch an explicitly sent Abort_Task_Interrupt from the
1261 -- Interrupt_Manager.
1263 -- There are two Interrupt interrupts that this task catch through
1264 -- "sigwait." One is the Interrupt this task is designated to catch
1265 -- in order to execute user handler or entry. The other one is the
1266 -- Abort_Task_Interrupt. This interrupt is being sent from the
1267 -- Interrupt_Manager to inform status changes (e.g: become Blocked,
1268 -- Handler or Entry is to be detached).
1270 -- Prepare a mask to used for sigwait
1272 IMOP
.Empty_Interrupt_Mask
(Intwait_Mask
'Access);
1274 IMOP
.Add_To_Interrupt_Mask
1275 (Intwait_Mask
'Access, IMNG
.Interrupt_ID
(Interrupt
));
1277 IMOP
.Add_To_Interrupt_Mask
1278 (Intwait_Mask
'Access, IMNG
.Abort_Task_Interrupt
);
1280 IMOP
.Thread_Block_Interrupt
1281 (IMNG
.Abort_Task_Interrupt
);
1283 PIO
.Set_Interrupt_ID
(IMNG
.Interrupt_ID
(Interrupt
), Self_ID
);
1286 System
.Tasking
.Initialization
.Defer_Abort
(Self_ID
);
1292 POP
.Write_Lock
(Self_ID
);
1294 if User_Handler
(Interrupt
).H
= null
1295 and then User_Entry
(Interrupt
).T
= Null_Task
1297 -- No Interrupt binding. If there is an interrupt,
1298 -- Interrupt_Manager will take default action.
1300 Self_ID
.Common
.State
:= Interrupt_Server_Blocked_Interrupt_Sleep
;
1301 POP
.Sleep
(Self_ID
, Interrupt_Server_Idle_Sleep
);
1302 Self_ID
.Common
.State
:= Runnable
;
1304 elsif Blocked
(Interrupt
) then
1306 -- Interrupt is blocked. Stay here, so we won't catch
1309 Self_ID
.Common
.State
:= Interrupt_Server_Blocked_Interrupt_Sleep
;
1310 POP
.Sleep
(Self_ID
, Interrupt_Server_Blocked_Interrupt_Sleep
);
1311 Self_ID
.Common
.State
:= Runnable
;
1314 -- A Handler or an Entry is installed. At this point all tasks
1315 -- mask for the Interrupt is masked. Catch the Interrupt using
1318 -- This task may wake up from sigwait by receiving an interrupt
1319 -- (Abort_Task_Interrupt) from the Interrupt_Manager for unbinding
1320 -- a Procedure Handler or an Entry. Or it could be a wake up
1321 -- from status change (Unblocked -> Blocked). If that is not
1322 -- the case, we should execute the attached Procedure or Entry.
1324 Self_ID
.Common
.State
:= Interrupt_Server_Blocked_On_Event_Flag
;
1325 POP
.Unlock
(Self_ID
);
1331 -- Avoid race condition when terminating application and
1332 -- System.Parameters.No_Abort is True.
1334 if Parameters
.No_Abort
and then Self_ID
.Pending_Action
then
1335 Initialization
.Do_Pending_Action
(Self_ID
);
1339 Interrupt_ID
(IMOP
.Interrupt_Wait
(Intwait_Mask
'Access));
1340 Self_ID
.Common
.State
:= Runnable
;
1342 if Ret_Interrupt
= Interrupt_ID
(IMNG
.Abort_Task_Interrupt
) then
1344 -- Inform the Interrupt_Manager of wakeup from above sigwait
1346 POP
.Abort_Task
(Interrupt_Manager_ID
);
1352 POP
.Write_Lock
(Self_ID
);
1359 POP
.Write_Lock
(Self_ID
);
1361 if Ret_Interrupt
/= Interrupt
then
1363 -- On some systems (e.g. recent linux kernels), sigwait
1364 -- may return unexpectedly (with errno set to EINTR).
1369 -- Even though we have received an Interrupt the status may
1370 -- have changed already before we got the Self_ID lock above
1371 -- Therefore we make sure a Handler or an Entry is still
1372 -- there and make appropriate call.
1374 -- If there is no calls to make we need to regenerate the
1375 -- Interrupt in order not to lose it.
1377 if User_Handler
(Interrupt
).H
/= null then
1378 Tmp_Handler
:= User_Handler
(Interrupt
).H
;
1380 -- RTS calls should not be made with self being locked
1382 POP
.Unlock
(Self_ID
);
1394 POP
.Write_Lock
(Self_ID
);
1396 elsif User_Entry
(Interrupt
).T
/= Null_Task
then
1397 Tmp_ID
:= User_Entry
(Interrupt
).T
;
1398 Tmp_Entry_Index
:= User_Entry
(Interrupt
).E
;
1400 -- RTS calls should not be made with self being locked
1406 POP
.Unlock
(Self_ID
);
1408 System
.Tasking
.Rendezvous
.Call_Simple
1409 (Tmp_ID
, Tmp_Entry_Index
, System
.Null_Address
);
1411 POP
.Write_Lock
(Self_ID
);
1418 -- This is a situation that this task wakes up receiving
1419 -- an Interrupt and before it gets the lock the Interrupt
1420 -- is blocked. We do not want to lose the interrupt in
1421 -- this case so we regenerate the Interrupt to process
1424 IMOP
.Interrupt_Self_Process
1425 (IMNG
.Interrupt_ID
(Interrupt
));
1431 POP
.Unlock
(Self_ID
);
1437 System
.Tasking
.Initialization
.Undefer_Abort
(Self_ID
);
1439 if Self_ID
.Pending_Action
then
1440 Initialization
.Do_Pending_Action
(Self_ID
);
1443 -- Undefer abort here to allow a window for this task to be aborted
1444 -- at the time of system shutdown. We also explicitly test for
1445 -- Pending_Action in case System.Parameters.No_Abort is True.
1450 -- Elaboration code for package System.Interrupts
1453 -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent
1455 Interrupt_Manager_ID
:= To_System
(Interrupt_Manager
'Identity);
1457 -- During the elaboration of this package body we want the RTS
1458 -- to inherit the interrupt mask from the Environment Task.
1460 IMOP
.Setup_Interrupt_Mask
;
1462 -- The environment task should have gotten its mask from the enclosing
1463 -- process during the RTS start up. (See processing in s-inmaop.adb). Pass
1464 -- the Interrupt_Mask of the environment task to the Interrupt_Manager.
1466 -- Note: At this point we know that all tasks are masked for non-reserved
1467 -- signals. Only the Interrupt_Manager will have masks set up differently
1468 -- inheriting the original environment task's mask.
1470 Interrupt_Manager
.Initialize
(IMOP
.Environment_Mask
);
1471 end System
.Interrupts
;