1 ------------------------------------------------------------------------------
3 -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- S Y S T E M . I N T E R R U P T S --
10 -- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
12 -- GNARL is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNARL; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- GNARL was developed by the GNARL team at Florida State University. It is --
31 -- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
33 ------------------------------------------------------------------------------
37 -- All user-handleable signals are masked at all times in all
38 -- tasks/threads except possibly for the Interrupt_Manager task.
40 -- When a user task wants to have the effect of masking/unmasking an
41 -- signal, it must call Block_Interrupt/Unblock_Interrupt, which
42 -- will have the effect of unmasking/masking the signal in the
43 -- Interrupt_Manager task. These comments do not apply to vectored
44 -- hardware interrupts, which may be masked or unmasked using routined
45 -- interfaced to the relevant VxWorks system calls.
47 -- Once we associate a Signal_Server_Task with an signal, the task never
48 -- goes away, and we never remove the association. On the other hand, it
49 -- is more convenient to terminate an associated Interrupt_Server_Task
50 -- for a vectored hardware interrupt (since we use a binary semaphore
51 -- for synchronization with the umbrella handler).
53 -- There is no more than one signal per Signal_Server_Task and no more than
54 -- one Signal_Server_Task per signal. The same relation holds for hardware
55 -- interrupts and Interrupt_Server_Task's at any given time. That is,
56 -- only one non-terminated Interrupt_Server_Task exists for a give
57 -- interrupt at any time.
59 -- Within this package, the lock L is used to protect the various status
60 -- tables. If there is a Server_Task associated with a signal or interrupt,
61 -- we use the per-task lock of the Server_Task instead so that we protect the
62 -- status between Interrupt_Manager and Server_Task. Protection among
63 -- service requests are ensured via user calls to the Interrupt_Manager
66 -- This is the VxWorks version of this package, supporting vectored hardware
69 with Unchecked_Conversion
;
71 with System
.OS_Interface
; use System
.OS_Interface
;
73 with Interfaces
.VxWorks
;
75 with Ada
.Task_Identification
;
76 -- used for Task_ID type
79 -- used for Raise_Exception
81 with System
.Task_Primitives
.Operations
;
82 -- used for Write_Lock
89 with System
.Storage_Elements
;
90 -- used for To_Address
99 -- Interrupt_Manager_ID
101 with System
.Tasking
.Utilities
;
102 -- used for Make_Independent
104 with System
.Tasking
.Rendezvous
;
105 -- used for Call_Simple
106 pragma Elaborate_All
(System
.Tasking
.Rendezvous
);
108 package body System
.Interrupts
is
113 package PRI
renames System
.Task_Primitives
;
114 package POP
renames System
.Task_Primitives
.Operations
;
116 function To_Ada
is new Unchecked_Conversion
117 (System
.Tasking
.Task_ID
, Ada
.Task_Identification
.Task_Id
);
119 function To_System
is new Unchecked_Conversion
120 (Ada
.Task_Identification
.Task_Id
, Task_ID
);
126 -- WARNING: System.Tasking.Stages performs calls to this task
127 -- with low-level constructs. Do not change this spec without synchro-
130 task Interrupt_Manager
is
131 entry Detach_Interrupt_Entries
(T
: Task_ID
);
134 (New_Handler
: Parameterless_Handler
;
135 Interrupt
: Interrupt_ID
;
137 Restoration
: Boolean := False);
139 entry Exchange_Handler
140 (Old_Handler
: out Parameterless_Handler
;
141 New_Handler
: Parameterless_Handler
;
142 Interrupt
: Interrupt_ID
;
146 (Interrupt
: Interrupt_ID
;
149 entry Bind_Interrupt_To_Entry
151 E
: Task_Entry_Index
;
152 Interrupt
: Interrupt_ID
);
154 pragma Interrupt_Priority
(System
.Interrupt_Priority
'First);
155 end Interrupt_Manager
;
157 task type Interrupt_Server_Task
158 (Interrupt
: Interrupt_ID
; Int_Sema
: SEM_ID
) is
159 -- Server task for vectored hardware interrupt handling
160 pragma Interrupt_Priority
(System
.Interrupt_Priority
'First + 2);
161 end Interrupt_Server_Task
;
163 type Interrupt_Task_Access
is access Interrupt_Server_Task
;
165 -------------------------------
166 -- Local Types and Variables --
167 -------------------------------
169 type Entry_Assoc
is record
171 E
: Task_Entry_Index
;
174 type Handler_Assoc
is record
175 H
: Parameterless_Handler
;
176 Static
: Boolean; -- Indicates static binding;
179 User_Handler
: array (Interrupt_ID
) of Handler_Assoc
:=
180 (others => (null, Static
=> False));
181 pragma Volatile_Components
(User_Handler
);
182 -- Holds the protected procedure handler (if any) and its Static
183 -- information for each interrupt or signal. A handler is static
184 -- iff it is specified through the pragma Attach_Handler.
186 User_Entry
: array (Interrupt_ID
) of Entry_Assoc
:=
187 (others => (T
=> Null_Task
, E
=> Null_Task_Entry
));
188 pragma Volatile_Components
(User_Entry
);
189 -- Holds the task and entry index (if any) for each interrupt / signal
191 -- Type and Head, Tail of the list containing Registered Interrupt
192 -- Handlers. These definitions are used to register the handlers
193 -- specified by the pragma Interrupt_Handler.
195 type Registered_Handler
;
196 type R_Link
is access all Registered_Handler
;
198 type Registered_Handler
is record
199 H
: System
.Address
:= System
.Null_Address
;
200 Next
: R_Link
:= null;
203 Registered_Handler_Head
: R_Link
:= null;
204 Registered_Handler_Tail
: R_Link
:= null;
206 Server_ID
: array (Interrupt_ID
) of System
.Tasking
.Task_ID
:=
207 (others => System
.Tasking
.Null_Task
);
208 pragma Atomic_Components
(Server_ID
);
209 -- Holds the Task_ID of the Server_Task for each interrupt / signal.
210 -- Task_ID is needed to accomplish locking per interrupt base. Also
211 -- is needed to determine whether to create a new Server_Task.
213 Semaphore_ID_Map
: array
214 (Interrupt_ID
range 0 .. System
.OS_Interface
.Max_HW_Interrupt
)
215 of SEM_ID
:= (others => 0);
216 -- Array of binary semaphores associated with vectored interrupts
217 -- Note that the last bound should be Max_HW_Interrupt, but this will raise
218 -- Storage_Error if Num_HW_Interrupts is null, so use an extra 4 bytes
221 Interrupt_Access_Hold
: Interrupt_Task_Access
;
222 -- Variable for allocating an Interrupt_Server_Task
224 Default_Handler
: array (HW_Interrupt
) of Interfaces
.VxWorks
.VOIDFUNCPTR
;
225 -- Vectored interrupt handlers installed prior to program startup.
226 -- These are saved only when the umbrella handler is installed for
227 -- a given interrupt number.
229 -----------------------
230 -- Local Subprograms --
231 -----------------------
233 procedure Check_Reserved_Interrupt
(Interrupt
: Interrupt_ID
);
234 -- Check if Id is a reserved interrupt, and if so raise Program_Error
235 -- with an appropriate message, otherwise return.
237 procedure Finalize_Interrupt_Servers
;
238 -- Unbind the handlers for hardware interrupt server tasks at program
241 function Is_Registered
(Handler
: Parameterless_Handler
) return Boolean;
242 -- See if Handler has been "pragma"ed using Interrupt_Handler.
243 -- Always consider a null handler as registered.
245 procedure Notify_Interrupt
(Param
: System
.Address
);
246 -- Umbrella handler for vectored interrupts (not signals)
248 procedure Install_Default_Action
(Interrupt
: HW_Interrupt
);
249 -- Restore a handler that was in place prior to program execution
251 procedure Install_Umbrella_Handler
252 (Interrupt
: HW_Interrupt
;
253 Handler
: Interfaces
.VxWorks
.VOIDFUNCPTR
);
254 -- Install the runtime umbrella handler for a vectored hardware
257 procedure Unimplemented
(Feature
: String);
258 pragma No_Return
(Unimplemented
);
259 -- Used to mark a call to an unimplemented function. Raises Program_Error
260 -- with an appropriate message noting that Feature is unimplemented.
266 -- Calling this procedure with New_Handler = null and Static = True
267 -- means we want to detach the current handler regardless of the
268 -- previous handler's binding status (ie. do not care if it is a
269 -- dynamic or static handler).
271 -- This option is needed so that during the finalization of a PO, we
272 -- can detach handlers attached through pragma Attach_Handler.
274 procedure Attach_Handler
275 (New_Handler
: Parameterless_Handler
;
276 Interrupt
: Interrupt_ID
;
277 Static
: Boolean := False) is
279 Check_Reserved_Interrupt
(Interrupt
);
280 Interrupt_Manager
.Attach_Handler
(New_Handler
, Interrupt
, Static
);
283 -----------------------------
284 -- Bind_Interrupt_To_Entry --
285 -----------------------------
287 -- This procedure raises a Program_Error if it tries to
288 -- bind an interrupt to which an Entry or a Procedure is
291 procedure Bind_Interrupt_To_Entry
293 E
: Task_Entry_Index
;
294 Int_Ref
: System
.Address
)
296 Interrupt
: constant Interrupt_ID
:=
297 Interrupt_ID
(Storage_Elements
.To_Integer
(Int_Ref
));
300 Check_Reserved_Interrupt
(Interrupt
);
301 Interrupt_Manager
.Bind_Interrupt_To_Entry
(T
, E
, Interrupt
);
302 end Bind_Interrupt_To_Entry
;
304 ---------------------
305 -- Block_Interrupt --
306 ---------------------
308 procedure Block_Interrupt
(Interrupt
: Interrupt_ID
) is
310 Unimplemented
("Block_Interrupt");
313 ------------------------------
314 -- Check_Reserved_Interrupt --
315 ------------------------------
317 procedure Check_Reserved_Interrupt
(Interrupt
: Interrupt_ID
) is
319 if Is_Reserved
(Interrupt
) then
321 (Program_Error
'Identity,
322 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved");
326 end Check_Reserved_Interrupt
;
328 ---------------------
329 -- Current_Handler --
330 ---------------------
332 function Current_Handler
333 (Interrupt
: Interrupt_ID
) return Parameterless_Handler
is
335 Check_Reserved_Interrupt
(Interrupt
);
337 -- ??? Since Parameterless_Handler is not Atomic, the
338 -- current implementation is wrong. We need a new service in
339 -- Interrupt_Manager to ensure atomicity.
341 return User_Handler
(Interrupt
).H
;
348 -- Calling this procedure with Static = True means we want to Detach the
349 -- current handler regardless of the previous handler's binding status
350 -- (i.e. do not care if it is a dynamic or static handler).
352 -- This option is needed so that during the finalization of a PO, we can
353 -- detach handlers attached through pragma Attach_Handler.
355 procedure Detach_Handler
356 (Interrupt
: Interrupt_ID
;
357 Static
: Boolean := False) is
359 Check_Reserved_Interrupt
(Interrupt
);
360 Interrupt_Manager
.Detach_Handler
(Interrupt
, Static
);
363 ------------------------------
364 -- Detach_Interrupt_Entries --
365 ------------------------------
367 procedure Detach_Interrupt_Entries
(T
: Task_ID
) is
369 Interrupt_Manager
.Detach_Interrupt_Entries
(T
);
370 end Detach_Interrupt_Entries
;
372 ----------------------
373 -- Exchange_Handler --
374 ----------------------
376 -- Calling this procedure with New_Handler = null and Static = True
377 -- means we want to detach the current handler regardless of the
378 -- previous handler's binding status (ie. do not care if it is a
379 -- dynamic or static handler).
381 -- This option is needed so that during the finalization of a PO, we
382 -- can detach handlers attached through pragma Attach_Handler.
384 procedure Exchange_Handler
385 (Old_Handler
: out Parameterless_Handler
;
386 New_Handler
: Parameterless_Handler
;
387 Interrupt
: Interrupt_ID
;
388 Static
: Boolean := False) is
390 Check_Reserved_Interrupt
(Interrupt
);
391 Interrupt_Manager
.Exchange_Handler
392 (Old_Handler
, New_Handler
, Interrupt
, Static
);
393 end Exchange_Handler
;
399 procedure Finalize
(Object
: in out Static_Interrupt_Protection
) is
401 -- ??? loop to be executed only when we're not doing library level
402 -- finalization, since in this case all interrupt / signal tasks are
405 if not Interrupt_Manager
'Terminated then
406 for N
in reverse Object
.Previous_Handlers
'Range loop
407 Interrupt_Manager
.Attach_Handler
408 (New_Handler
=> Object
.Previous_Handlers
(N
).Handler
,
409 Interrupt
=> Object
.Previous_Handlers
(N
).Interrupt
,
410 Static
=> Object
.Previous_Handlers
(N
).Static
,
411 Restoration
=> True);
415 Tasking
.Protected_Objects
.Entries
.Finalize
416 (Tasking
.Protected_Objects
.Entries
.Protection_Entries
(Object
));
419 --------------------------------
420 -- Finalize_Interrupt_Servers --
421 --------------------------------
423 -- Restore default handlers for interrupt servers.
424 -- This is called by the Interrupt_Manager task when it receives the abort
425 -- signal during program finalization.
427 procedure Finalize_Interrupt_Servers
is
429 if HW_Interrupt
'Last >= 0 then
430 for Int
in HW_Interrupt
loop
431 if Server_ID
(Interrupt_ID
(Int
)) /= null
433 not Ada
.Task_Identification
.Is_Terminated
434 (To_Ada
(Server_ID
(Interrupt_ID
(Int
))))
436 Interrupt_Manager
.Attach_Handler
437 (New_Handler
=> null,
438 Interrupt
=> Interrupt_ID
(Int
),
440 Restoration
=> True);
444 end Finalize_Interrupt_Servers
;
446 -------------------------------------
447 -- Has_Interrupt_Or_Attach_Handler --
448 -------------------------------------
450 function Has_Interrupt_Or_Attach_Handler
451 (Object
: access Dynamic_Interrupt_Protection
) return Boolean is
454 end Has_Interrupt_Or_Attach_Handler
;
456 function Has_Interrupt_Or_Attach_Handler
457 (Object
: access Static_Interrupt_Protection
) return Boolean is
460 end Has_Interrupt_Or_Attach_Handler
;
462 ----------------------
463 -- Ignore_Interrupt --
464 ----------------------
466 procedure Ignore_Interrupt
(Interrupt
: Interrupt_ID
) is
468 Unimplemented
("Ignore_Interrupt");
469 end Ignore_Interrupt
;
471 ----------------------------
472 -- Install_Default_Action --
473 ----------------------------
475 procedure Install_Default_Action
(Interrupt
: HW_Interrupt
) is
477 -- Restore original interrupt handler
479 Interfaces
.VxWorks
.intVecSet
480 (Interfaces
.VxWorks
.INUM_TO_IVEC
(Integer (Interrupt
)),
481 Default_Handler
(Interrupt
));
482 Default_Handler
(Interrupt
) := null;
483 end Install_Default_Action
;
485 ----------------------
486 -- Install_Handlers --
487 ----------------------
489 procedure Install_Handlers
490 (Object
: access Static_Interrupt_Protection
;
491 New_Handlers
: New_Handler_Array
) is
493 for N
in New_Handlers
'Range loop
494 -- We need a lock around this ???
496 Object
.Previous_Handlers
(N
).Interrupt
:= New_Handlers
(N
).Interrupt
;
497 Object
.Previous_Handlers
(N
).Static
:= User_Handler
498 (New_Handlers
(N
).Interrupt
).Static
;
500 -- We call Exchange_Handler and not directly Interrupt_Manager.
501 -- Exchange_Handler so we get the Is_Reserved check.
504 (Old_Handler
=> Object
.Previous_Handlers
(N
).Handler
,
505 New_Handler
=> New_Handlers
(N
).Handler
,
506 Interrupt
=> New_Handlers
(N
).Interrupt
,
509 end Install_Handlers
;
511 ------------------------------
512 -- Install_Umbrella_Handler --
513 ------------------------------
515 procedure Install_Umbrella_Handler
516 (Interrupt
: HW_Interrupt
;
517 Handler
: Interfaces
.VxWorks
.VOIDFUNCPTR
)
519 use Interfaces
.VxWorks
;
521 Vec
: constant Interrupt_Vector
:=
522 INUM_TO_IVEC
(Interfaces
.VxWorks
.int
(Interrupt
));
523 Old_Handler
: constant VOIDFUNCPTR
:=
524 intVecGet
(INUM_TO_IVEC
(Interfaces
.VxWorks
.int
(Interrupt
)));
525 Stat
: Interfaces
.VxWorks
.STATUS
;
528 -- Only install umbrella handler when no Ada handler has already been
529 -- installed. Note that the interrupt number is passed as a parameter
530 -- when an interrupt occurs, so the umbrella handler has a different
531 -- wrapper generated by intConnect for each interrupt number.
533 if Default_Handler
(Interrupt
) = null then
535 intConnect
(Vec
, VOIDFUNCPTR
(Handler
), System
.Address
(Interrupt
));
536 Default_Handler
(Interrupt
) := Old_Handler
;
538 end Install_Umbrella_Handler
;
544 function Is_Blocked
(Interrupt
: Interrupt_ID
) return Boolean is
546 Unimplemented
("Is_Blocked");
550 -----------------------
551 -- Is_Entry_Attached --
552 -----------------------
554 function Is_Entry_Attached
(Interrupt
: Interrupt_ID
) return Boolean is
556 Check_Reserved_Interrupt
(Interrupt
);
557 return User_Entry
(Interrupt
).T
/= Null_Task
;
558 end Is_Entry_Attached
;
560 -------------------------
561 -- Is_Handler_Attached --
562 -------------------------
564 function Is_Handler_Attached
(Interrupt
: Interrupt_ID
) return Boolean is
566 Check_Reserved_Interrupt
(Interrupt
);
567 return User_Handler
(Interrupt
).H
/= null;
568 end Is_Handler_Attached
;
574 function Is_Ignored
(Interrupt
: Interrupt_ID
) return Boolean is
576 Unimplemented
("Is_Ignored");
584 function Is_Registered
(Handler
: Parameterless_Handler
) return Boolean is
585 type Fat_Ptr
is record
586 Object_Addr
: System
.Address
;
587 Handler_Addr
: System
.Address
;
590 function To_Fat_Ptr
is new Unchecked_Conversion
591 (Parameterless_Handler
, Fat_Ptr
);
597 if Handler
= null then
601 Fat
:= To_Fat_Ptr
(Handler
);
603 Ptr
:= Registered_Handler_Head
;
605 while (Ptr
/= null) loop
606 if Ptr
.H
= Fat
.Handler_Addr
then
620 function Is_Reserved
(Interrupt
: Interrupt_ID
) return Boolean is
625 ----------------------
626 -- Notify_Interrupt --
627 ----------------------
629 -- Umbrella handler for vectored hardware interrupts (as opposed to
630 -- signals and exceptions). As opposed to the signal implementation,
631 -- this handler is only installed in the vector table while there is
632 -- an active association of an Ada handler to the interrupt.
634 -- Otherwise, the handler that existed prior to program startup is
635 -- in the vector table. This ensures that handlers installed by
636 -- the BSP are active unless explicitly replaced in the program text.
638 -- Each Interrupt_Server_Task has an associated binary semaphore
639 -- on which it pends once it's been started. This routine determines
640 -- The appropriate semaphore and and issues a semGive call, waking
641 -- the server task. When a handler is unbound,
642 -- System.Interrupts.Unbind_Handler issues a semFlush, and the
643 -- server task deletes its semaphore and terminates.
645 procedure Notify_Interrupt
(Param
: System
.Address
) is
646 Interrupt
: Interrupt_ID
:= Interrupt_ID
(Param
);
647 Discard_Result
: STATUS
;
650 Discard_Result
:= semGive
(Semaphore_ID_Map
(Interrupt
));
651 end Notify_Interrupt
;
657 function Reference
(Interrupt
: Interrupt_ID
) return System
.Address
is
659 Check_Reserved_Interrupt
(Interrupt
);
660 return Storage_Elements
.To_Address
661 (Storage_Elements
.Integer_Address
(Interrupt
));
664 --------------------------------
665 -- Register_Interrupt_Handler --
666 --------------------------------
668 procedure Register_Interrupt_Handler
(Handler_Addr
: System
.Address
) is
669 New_Node_Ptr
: R_Link
;
671 -- This routine registers a handler as usable for dynamic
672 -- interrupt handler association. Routines attaching and detaching
673 -- handlers dynamically should determine whether the handler is
674 -- registered. Program_Error should be raised if it is not registered.
676 -- Pragma Interrupt_Handler can only appear in a library
677 -- level PO definition and instantiation. Therefore, we do not need
678 -- to implement an unregister operation. Nor do we need to
679 -- protect the queue structure with a lock.
681 pragma Assert
(Handler_Addr
/= System
.Null_Address
);
683 New_Node_Ptr
:= new Registered_Handler
;
684 New_Node_Ptr
.H
:= Handler_Addr
;
686 if Registered_Handler_Head
= null then
687 Registered_Handler_Head
:= New_Node_Ptr
;
688 Registered_Handler_Tail
:= New_Node_Ptr
;
691 Registered_Handler_Tail
.Next
:= New_Node_Ptr
;
692 Registered_Handler_Tail
:= New_Node_Ptr
;
694 end Register_Interrupt_Handler
;
696 -----------------------
697 -- Unblock_Interrupt --
698 -----------------------
700 procedure Unblock_Interrupt
(Interrupt
: Interrupt_ID
) is
702 Unimplemented
("Unblock_Interrupt");
703 end Unblock_Interrupt
;
709 function Unblocked_By
710 (Interrupt
: Interrupt_ID
) return System
.Tasking
.Task_ID
is
712 Unimplemented
("Unblocked_By");
716 ------------------------
717 -- Unignore_Interrupt --
718 ------------------------
720 procedure Unignore_Interrupt
(Interrupt
: Interrupt_ID
) is
722 Unimplemented
("Unignore_Interrupt");
723 end Unignore_Interrupt
;
729 procedure Unimplemented
(Feature
: String) is
732 (Program_Error
'Identity,
733 Feature
& " not implemented on VxWorks");
736 -----------------------
737 -- Interrupt_Manager --
738 -----------------------
740 task body Interrupt_Manager
is
741 ---------------------
742 -- Local Variables --
743 ---------------------
745 Self_Id
: constant Task_ID
:= POP
.Self
;
751 procedure Bind_Handler
(Interrupt
: Interrupt_ID
);
752 -- This procedure does not do anything if a signal is blocked.
753 -- Otherwise, we have to interrupt Server_Task for status change through
756 procedure Unbind_Handler
(Interrupt
: Interrupt_ID
);
757 -- This procedure does not do anything if a signal is blocked.
758 -- Otherwise, we have to interrupt Server_Task for status change
759 -- through an abort signal.
761 procedure Unprotected_Exchange_Handler
762 (Old_Handler
: out Parameterless_Handler
;
763 New_Handler
: Parameterless_Handler
;
764 Interrupt
: Interrupt_ID
;
766 Restoration
: Boolean := False);
768 procedure Unprotected_Detach_Handler
769 (Interrupt
: Interrupt_ID
;
776 procedure Bind_Handler
(Interrupt
: Interrupt_ID
) is
778 Install_Umbrella_Handler
779 (HW_Interrupt
(Interrupt
), Notify_Interrupt
'Access);
786 procedure Unbind_Handler
(Interrupt
: Interrupt_ID
) is
791 -- Hardware interrupt
793 Install_Default_Action
(HW_Interrupt
(Interrupt
));
795 -- Flush server task off semaphore, allowing it to terminate
797 S
:= semFlush
(Semaphore_ID_Map
(Interrupt
));
798 pragma Assert
(S
= 0);
801 --------------------------------
802 -- Unprotected_Detach_Handler --
803 --------------------------------
805 procedure Unprotected_Detach_Handler
806 (Interrupt
: Interrupt_ID
;
809 Old_Handler
: Parameterless_Handler
;
811 if User_Entry
(Interrupt
).T
/= Null_Task
then
812 -- If an interrupt entry is installed raise
813 -- Program_Error. (propagate it to the caller).
815 Raise_Exception
(Program_Error
'Identity,
816 "An interrupt entry is already installed");
819 -- Note : Static = True will pass the following check. This is the
820 -- case when we want to detach a handler regardless of the static
821 -- status of the Current_Handler.
823 if not Static
and then User_Handler
(Interrupt
).Static
then
824 -- Trying to detach a static Interrupt Handler.
825 -- raise Program_Error.
827 Raise_Exception
(Program_Error
'Identity,
828 "Trying to detach a static Interrupt Handler");
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) is
854 if User_Entry
(Interrupt
).T
/= Null_Task
then
855 -- If an interrupt entry is already installed, raise
856 -- Program_Error. (propagate it to the caller).
859 (Program_Error
'Identity,
860 "An interrupt is already installed");
863 -- Note : A null handler with Static = True will
864 -- pass the following check. This is the case when we want to
865 -- detach a handler regardless of the Static status
866 -- of Current_Handler.
867 -- We don't check anything if Restoration is True, since we
868 -- may be detaching a static handler to restore a dynamic one.
870 if not Restoration
and then not Static
871 and then (User_Handler
(Interrupt
).Static
873 -- Trying to overwrite a static Interrupt Handler with a
876 -- The new handler is not specified as an
877 -- Interrupt Handler by a pragma.
879 or else not Is_Registered
(New_Handler
))
882 (Program_Error
'Identity,
883 "Trying to overwrite a static Interrupt Handler with a " &
887 -- Save the old handler
889 Old_Handler
:= User_Handler
(Interrupt
).H
;
893 User_Handler
(Interrupt
).H
:= New_Handler
;
895 if New_Handler
= null then
897 -- The null handler means we are detaching the handler.
899 User_Handler
(Interrupt
).Static
:= False;
902 User_Handler
(Interrupt
).Static
:= Static
;
905 -- Invoke a corresponding Server_Task if not yet created.
906 -- Place Task_ID info in Server_ID array.
908 if New_Handler
/= null
910 (Server_ID
(Interrupt
) = Null_Task
912 Ada
.Task_Identification
.Is_Terminated
913 (To_Ada
(Server_ID
(Interrupt
))))
915 Interrupt_Access_Hold
:=
916 new Interrupt_Server_Task
917 (Interrupt
, semBCreate
(SEM_Q_FIFO
, SEM_EMPTY
));
918 Server_ID
(Interrupt
) :=
919 To_System
(Interrupt_Access_Hold
.all'Identity);
922 if (New_Handler
= null) and then Old_Handler
/= null then
923 -- Restore default handler
925 Unbind_Handler
(Interrupt
);
927 elsif Old_Handler
= null then
928 -- Save default handler
930 Bind_Handler
(Interrupt
);
932 end Unprotected_Exchange_Handler
;
934 -- Start of processing for Interrupt_Manager
937 -- By making this task independent of any master, when the process
938 -- goes away, the Interrupt_Manager will terminate gracefully.
940 System
.Tasking
.Utilities
.Make_Independent
;
943 -- A block is needed to absorb Program_Error exception
946 Old_Handler
: Parameterless_Handler
;
950 accept Attach_Handler
951 (New_Handler
: Parameterless_Handler
;
952 Interrupt
: Interrupt_ID
;
954 Restoration
: Boolean := False)
956 Unprotected_Exchange_Handler
957 (Old_Handler
, New_Handler
, Interrupt
, Static
, Restoration
);
961 accept Exchange_Handler
962 (Old_Handler
: out Parameterless_Handler
;
963 New_Handler
: Parameterless_Handler
;
964 Interrupt
: Interrupt_ID
;
967 Unprotected_Exchange_Handler
968 (Old_Handler
, New_Handler
, Interrupt
, Static
);
969 end Exchange_Handler
;
972 accept Detach_Handler
973 (Interrupt
: Interrupt_ID
;
976 Unprotected_Detach_Handler
(Interrupt
, Static
);
979 accept Bind_Interrupt_To_Entry
981 E
: Task_Entry_Index
;
982 Interrupt
: Interrupt_ID
)
984 -- If there is a binding already (either a procedure or an
985 -- entry), raise Program_Error (propagate it to the caller).
987 if User_Handler
(Interrupt
).H
/= null
988 or else User_Entry
(Interrupt
).T
/= Null_Task
991 (Program_Error
'Identity,
992 "A binding for this interrupt is already present");
995 User_Entry
(Interrupt
) := Entry_Assoc
' (T => T, E => E);
997 -- Indicate the attachment of interrupt entry in the ATCB.
998 -- This is needed so when an interrupt entry task terminates
999 -- the binding can be cleaned. The call to unbinding must be
1000 -- make by the task before it terminates.
1002 T.Interrupt_Entry := True;
1004 -- Invoke a corresponding Server_Task if not yet created.
1005 -- Place Task_ID info in Server_ID array.
1007 if Server_ID (Interrupt) = Null_Task
1009 Ada.Task_Identification.Is_Terminated
1010 (To_Ada (Server_ID (Interrupt)))
1012 Interrupt_Access_Hold := new Interrupt_Server_Task
1013 (Interrupt, semBCreate (SEM_Q_FIFO, SEM_EMPTY));
1014 Server_ID (Interrupt) :=
1015 To_System (Interrupt_Access_Hold.all'Identity);
1018 Bind_Handler (Interrupt);
1019 end Bind_Interrupt_To_Entry;
1022 accept Detach_Interrupt_Entries (T : Task_ID) do
1023 for Int in Interrupt_ID'Range loop
1024 if not Is_Reserved (Int) then
1025 if User_Entry (Int).T = T then
1026 User_Entry (Int) := Entry_Assoc'
1027 (T
=> Null_Task
, E
=> Null_Task_Entry
);
1028 Unbind_Handler
(Int
);
1033 -- Indicate in ATCB that no interrupt entries are attached.
1035 T
.Interrupt_Entry
:= False;
1036 end Detach_Interrupt_Entries
;
1040 -- If there is a Program_Error we just want to propagate it to
1041 -- the caller and do not want to stop this task.
1043 when Program_Error
=>
1047 pragma Assert
(False);
1053 when Standard
'Abort_Signal =>
1054 -- Flush interrupt server semaphores, so they can terminate
1055 Finalize_Interrupt_Servers
;
1057 end Interrupt_Manager
;
1059 ---------------------------
1060 -- Interrupt_Server_Task --
1061 ---------------------------
1063 -- Server task for vectored hardware interrupt handling
1065 task body Interrupt_Server_Task
is
1066 Self_Id
: constant Task_ID
:= Self
;
1067 Tmp_Handler
: Parameterless_Handler
;
1069 Tmp_Entry_Index
: Task_Entry_Index
;
1075 System
.Tasking
.Utilities
.Make_Independent
;
1076 Semaphore_ID_Map
(Interrupt
) := Int_Sema
;
1079 -- Pend on semaphore that will be triggered by the
1080 -- umbrella handler when the associated interrupt comes in
1082 S
:= semTake
(Int_Sema
, WAIT_FOREVER
);
1083 pragma Assert
(S
= 0);
1085 if User_Handler
(Interrupt
).H
/= null then
1087 -- Protected procedure handler
1089 Tmp_Handler
:= User_Handler
(Interrupt
).H
;
1092 elsif User_Entry
(Interrupt
).T
/= Null_Task
then
1094 -- Interrupt entry handler
1096 Tmp_ID
:= User_Entry
(Interrupt
).T
;
1097 Tmp_Entry_Index
:= User_Entry
(Interrupt
).E
;
1098 System
.Tasking
.Rendezvous
.Call_Simple
1099 (Tmp_ID
, Tmp_Entry_Index
, System
.Null_Address
);
1102 -- Semaphore has been flushed by an unbind operation in
1103 -- the Interrupt_Manager. Terminate the server task.
1105 -- Wait for the Interrupt_Manager to complete its work
1107 POP
.Write_Lock
(Self_Id
);
1109 -- Delete the associated semaphore
1111 S
:= semDelete
(Int_Sema
);
1113 pragma Assert
(S
= 0);
1115 -- Set status for the Interrupt_Manager
1117 Semaphore_ID_Map
(Interrupt
) := 0;
1118 Server_ID
(Interrupt
) := Null_Task
;
1119 POP
.Unlock
(Self_Id
);
1124 end Interrupt_Server_Task
;
1127 -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent.
1129 Interrupt_Manager_ID
:= To_System
(Interrupt_Manager
'Identity);
1130 end System
.Interrupts
;