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 --
9 -- Copyright (C) 1998-2004 Free Software Fundation --
11 -- GNARL is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNARL; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNARL was developed by the GNARL team at Florida State University. --
30 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
32 ------------------------------------------------------------------------------
34 -- This is the IRIX & NT version of this package.
36 with Ada
.Task_Identification
;
40 -- used for Raise_Exception
42 with System
.OS_Interface
;
43 -- used for intr_attach
45 with System
.Storage_Elements
;
46 -- used for To_Address
49 with System
.Task_Primitives
.Operations
;
56 with System
.Tasking
.Utilities
;
57 -- used for Make_Independent
59 with System
.Tasking
.Rendezvous
;
60 -- used for Call_Simple
62 with System
.Tasking
.Initialization
;
63 -- used for Defer_Abort
66 with System
.Interrupt_Management
;
68 with System
.Parameters
;
69 -- used for Single_Lock
74 with Unchecked_Conversion
;
76 package body System
.Interrupts
is
81 use System
.OS_Interface
;
84 package STPO
renames System
.Task_Primitives
.Operations
;
85 package IMNG
renames System
.Interrupt_Management
;
87 subtype int
is Interfaces
.C
.int
;
89 function To_System
is new Unchecked_Conversion
90 (Ada
.Task_Identification
.Task_Id
, Task_ID
);
92 type Handler_Kind
is (Unknown
, Task_Entry
, Protected_Procedure
);
94 type Handler_Desc
is record
95 Kind
: Handler_Kind
:= Unknown
;
98 H
: Parameterless_Handler
;
99 Static
: Boolean := False;
102 task type Server_Task
(Interrupt
: Interrupt_ID
) is
103 pragma Interrupt_Priority
(System
.Interrupt_Priority
'Last);
106 type Server_Task_Access
is access Server_Task
;
108 Attached_Interrupts
: array (Interrupt_ID
) of Boolean;
109 Handlers
: array (Interrupt_ID
) of Task_ID
;
110 Descriptors
: array (Interrupt_ID
) of Handler_Desc
;
111 Interrupt_Count
: array (Interrupt_ID
) of Integer := (others => 0);
113 pragma Volatile_Components
(Interrupt_Count
);
115 procedure Attach_Handler
116 (New_Handler
: Parameterless_Handler
;
117 Interrupt
: Interrupt_ID
;
119 Restoration
: Boolean);
120 -- This internal procedure is needed to finalize protected objects
121 -- that contain interrupt handlers.
123 procedure Signal_Handler
(Sig
: Interrupt_ID
);
124 -- This procedure is used to handle all the signals.
126 -- Type and Head, Tail of the list containing Registered Interrupt
127 -- Handlers. These definitions are used to register the handlers
128 -- specified by the pragma Interrupt_Handler.
131 -- Handler Registration:
134 type Registered_Handler
;
135 type R_Link
is access all Registered_Handler
;
137 type Registered_Handler
is record
138 H
: System
.Address
:= System
.Null_Address
;
139 Next
: R_Link
:= null;
142 Registered_Handlers
: R_Link
:= null;
144 function Is_Registered
(Handler
: Parameterless_Handler
) return Boolean;
145 -- See if the Handler has been "pragma"ed using Interrupt_Handler.
146 -- Always consider a null handler as registered.
148 type Handler_Ptr
is access procedure (Sig
: Interrupt_ID
);
150 function TISR
is new Unchecked_Conversion
(Handler_Ptr
, isr_address
);
152 procedure Signal_Handler
(Sig
: Interrupt_ID
) is
153 Handler
: Task_ID
renames Handlers
(Sig
);
155 if Intr_Attach_Reset
and then
156 intr_attach
(int
(Sig
), TISR
(Signal_Handler
'Access)) = FUNC_ERR
161 if Handler
/= null then
162 Interrupt_Count
(Sig
) := Interrupt_Count
(Sig
) + 1;
163 STPO
.Wakeup
(Handler
, Interrupt_Server_Idle_Sleep
);
171 function Is_Reserved
(Interrupt
: Interrupt_ID
) return Boolean is
173 return IMNG
.Reserve
(IMNG
.Interrupt_ID
(Interrupt
));
176 -----------------------
177 -- Is_Entry_Attached --
178 -----------------------
180 function Is_Entry_Attached
(Interrupt
: Interrupt_ID
) return Boolean is
182 if Is_Reserved
(Interrupt
) then
183 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
184 Interrupt_ID
'Image (Interrupt
) & " is reserved");
187 return Descriptors
(Interrupt
).T
/= Null_Task
;
188 end Is_Entry_Attached
;
190 -------------------------
191 -- Is_Handler_Attached --
192 -------------------------
194 function Is_Handler_Attached
(Interrupt
: Interrupt_ID
) return Boolean is
196 if Is_Reserved
(Interrupt
) then
197 Raise_Exception
(Program_Error
'Identity, "Interrupt" &
198 Interrupt_ID
'Image (Interrupt
) & " is reserved");
201 return Descriptors
(Interrupt
).Kind
/= Unknown
;
202 end Is_Handler_Attached
;
208 function Is_Ignored
(Interrupt
: Interrupt_ID
) return Boolean is
218 function Unblocked_By
(Interrupt
: Interrupt_ID
) return Task_ID
is
224 ----------------------
225 -- Ignore_Interrupt --
226 ----------------------
228 procedure Ignore_Interrupt
(Interrupt
: Interrupt_ID
) is
231 end Ignore_Interrupt
;
233 ------------------------
234 -- Unignore_Interrupt --
235 ------------------------
237 procedure Unignore_Interrupt
(Interrupt
: Interrupt_ID
) is
240 end Unignore_Interrupt
;
242 -------------------------------------
243 -- Has_Interrupt_Or_Attach_Handler --
244 -------------------------------------
246 function Has_Interrupt_Or_Attach_Handler
247 (Object
: access Dynamic_Interrupt_Protection
) return Boolean
249 pragma Unreferenced
(Object
);
252 end Has_Interrupt_Or_Attach_Handler
;
258 procedure Finalize
(Object
: in out Static_Interrupt_Protection
) is
260 -- ??? loop to be executed only when we're not doing library level
261 -- finalization, since in this case all interrupt tasks are gone.
263 for N
in reverse Object
.Previous_Handlers
'Range loop
265 (New_Handler
=> Object
.Previous_Handlers
(N
).Handler
,
266 Interrupt
=> Object
.Previous_Handlers
(N
).Interrupt
,
267 Static
=> Object
.Previous_Handlers
(N
).Static
,
268 Restoration
=> True);
271 Tasking
.Protected_Objects
.Entries
.Finalize
272 (Tasking
.Protected_Objects
.Entries
.Protection_Entries
(Object
));
275 -------------------------------------
276 -- Has_Interrupt_Or_Attach_Handler --
277 -------------------------------------
279 function Has_Interrupt_Or_Attach_Handler
280 (Object
: access Static_Interrupt_Protection
) return Boolean
282 pragma Unreferenced
(Object
);
285 end Has_Interrupt_Or_Attach_Handler
;
287 ----------------------
288 -- Install_Handlers --
289 ----------------------
291 procedure Install_Handlers
292 (Object
: access Static_Interrupt_Protection
;
293 New_Handlers
: New_Handler_Array
)
296 for N
in New_Handlers
'Range loop
298 -- We need a lock around this ???
300 Object
.Previous_Handlers
(N
).Interrupt
:= New_Handlers
(N
).Interrupt
;
301 Object
.Previous_Handlers
(N
).Static
:= Descriptors
302 (New_Handlers
(N
).Interrupt
).Static
;
304 -- We call Exchange_Handler and not directly Interrupt_Manager.
305 -- Exchange_Handler so we get the Is_Reserved check.
308 (Old_Handler
=> Object
.Previous_Handlers
(N
).Handler
,
309 New_Handler
=> New_Handlers
(N
).Handler
,
310 Interrupt
=> New_Handlers
(N
).Interrupt
,
313 end Install_Handlers
;
315 ---------------------
316 -- Current_Handler --
317 ---------------------
319 function Current_Handler
320 (Interrupt
: Interrupt_ID
) return Parameterless_Handler
323 if Is_Reserved
(Interrupt
) then
327 if Descriptors
(Interrupt
).Kind
= Protected_Procedure
then
328 return Descriptors
(Interrupt
).H
;
338 procedure Attach_Handler
339 (New_Handler
: Parameterless_Handler
;
340 Interrupt
: Interrupt_ID
;
341 Static
: Boolean := False) is
343 Attach_Handler
(New_Handler
, Interrupt
, Static
, False);
346 procedure Attach_Handler
347 (New_Handler
: Parameterless_Handler
;
348 Interrupt
: Interrupt_ID
;
350 Restoration
: Boolean)
352 New_Task
: Server_Task_Access
;
355 if Is_Reserved
(Interrupt
) then
359 if not Restoration
and then not Static
361 -- Tries to overwrite a static Interrupt Handler with a
364 and then (Descriptors
(Interrupt
).Static
366 -- The new handler is not specified as an
367 -- Interrupt Handler by a pragma.
369 or else not Is_Registered
(New_Handler
))
371 Raise_Exception
(Program_Error
'Identity,
372 "Trying to overwrite a static Interrupt Handler with a " &
376 if Handlers
(Interrupt
) = null then
377 New_Task
:= new Server_Task
(Interrupt
);
378 Handlers
(Interrupt
) := To_System
(New_Task
.all'Identity);
381 if intr_attach
(int
(Interrupt
),
382 TISR
(Signal_Handler
'Access)) = FUNC_ERR
387 if New_Handler
= null then
389 -- The null handler means we are detaching the handler.
391 Attached_Interrupts
(Interrupt
) := False;
392 Descriptors
(Interrupt
) :=
393 (Kind
=> Unknown
, T
=> null, E
=> 0, H
=> null, Static
=> False);
396 Descriptors
(Interrupt
).Kind
:= Protected_Procedure
;
397 Descriptors
(Interrupt
).H
:= New_Handler
;
398 Descriptors
(Interrupt
).Static
:= Static
;
399 Attached_Interrupts
(Interrupt
) := True;
403 ----------------------
404 -- Exchange_Handler --
405 ----------------------
407 procedure Exchange_Handler
408 (Old_Handler
: out Parameterless_Handler
;
409 New_Handler
: Parameterless_Handler
;
410 Interrupt
: Interrupt_ID
;
411 Static
: Boolean := False) is
413 if Is_Reserved
(Interrupt
) then
417 if Descriptors
(Interrupt
).Kind
= Task_Entry
then
419 -- In case we have an Interrupt Entry already installed.
420 -- raise a program error. (propagate it to the caller).
422 Raise_Exception
(Program_Error
'Identity,
423 "An interrupt is already installed");
426 Old_Handler
:= Current_Handler
(Interrupt
);
427 Attach_Handler
(New_Handler
, Interrupt
, Static
);
428 end Exchange_Handler
;
434 procedure Detach_Handler
435 (Interrupt
: Interrupt_ID
;
436 Static
: Boolean := False) is
438 if Is_Reserved
(Interrupt
) then
442 if Descriptors
(Interrupt
).Kind
= Task_Entry
then
443 Raise_Exception
(Program_Error
'Identity,
444 "Trying to detach an Interrupt Entry");
447 if not Static
and then Descriptors
(Interrupt
).Static
then
448 Raise_Exception
(Program_Error
'Identity,
449 "Trying to detach a static Interrupt Handler");
452 Attached_Interrupts
(Interrupt
) := False;
453 Descriptors
(Interrupt
) :=
454 (Kind
=> Unknown
, T
=> null, E
=> 0, H
=> null, Static
=> False);
456 if intr_attach
(int
(Interrupt
), null) = FUNC_ERR
then
465 function Reference
(Interrupt
: Interrupt_ID
) return System
.Address
is
466 Signal
: constant System
.Address
:=
467 System
.Storage_Elements
.To_Address
468 (System
.Storage_Elements
.Integer_Address
(Interrupt
));
471 if Is_Reserved
(Interrupt
) then
473 -- Only usable Interrupts can be used for binding it to an Entry
481 --------------------------------
482 -- Register_Interrupt_Handler --
483 --------------------------------
485 procedure Register_Interrupt_Handler
(Handler_Addr
: System
.Address
) is
487 Registered_Handlers
:=
488 new Registered_Handler
'(H => Handler_Addr, Next => Registered_Handlers);
489 end Register_Interrupt_Handler;
495 -- See if the Handler has been "pragma"ed using Interrupt_Handler.
496 -- Always consider a null handler as registered.
498 function Is_Registered (Handler : Parameterless_Handler) return Boolean is
499 Ptr : R_Link := Registered_Handlers;
501 type Fat_Ptr is record
502 Object_Addr : System.Address;
503 Handler_Addr : System.Address;
506 function To_Fat_Ptr is new Unchecked_Conversion
507 (Parameterless_Handler, Fat_Ptr);
512 if Handler = null then
516 Fat := To_Fat_Ptr (Handler);
518 while Ptr /= null loop
520 if Ptr.H = Fat.Handler_Addr then
530 -----------------------------
531 -- Bind_Interrupt_To_Entry --
532 -----------------------------
534 procedure Bind_Interrupt_To_Entry
536 E : Task_Entry_Index;
537 Int_Ref : System.Address)
539 Interrupt : constant Interrupt_ID :=
540 Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
542 New_Task : Server_Task_Access;
545 if Is_Reserved (Interrupt) then
549 if Descriptors (Interrupt).Kind /= Unknown then
550 Raise_Exception (Program_Error'Identity,
551 "A binding for this interrupt is already present");
554 if Handlers (Interrupt) = null then
555 New_Task := new Server_Task (Interrupt);
556 Handlers (Interrupt) := To_System (New_Task.all'Identity);
559 if intr_attach (int (Interrupt),
560 TISR (Signal_Handler'Access)) = FUNC_ERR
565 Descriptors (Interrupt).Kind := Task_Entry;
566 Descriptors (Interrupt).T := T;
567 Descriptors (Interrupt).E := E;
569 -- Indicate the attachment of Interrupt Entry in ATCB.
570 -- This is need so that when an Interrupt Entry task terminates
571 -- the binding can be cleaned. The call to unbinding must be
572 -- make by the task before it terminates.
574 T.Interrupt_Entry := True;
576 Attached_Interrupts (Interrupt) := True;
577 end Bind_Interrupt_To_Entry;
579 ------------------------------
580 -- Detach_Interrupt_Entries --
581 ------------------------------
583 procedure Detach_Interrupt_Entries (T : Task_ID) is
585 for I in Interrupt_ID loop
586 if not Is_Reserved (I) then
587 if Descriptors (I).Kind = Task_Entry and then
588 Descriptors (I).T = T then
589 Attached_Interrupts (I) := False;
590 Descriptors (I).Kind := Unknown;
592 if intr_attach (int (I), null) = FUNC_ERR then
599 -- Indicate in ATCB that no Interrupt Entries are attached.
601 T.Interrupt_Entry := True;
602 end Detach_Interrupt_Entries;
604 ---------------------
605 -- Block_Interrupt --
606 ---------------------
608 procedure Block_Interrupt (Interrupt : Interrupt_ID) is
613 -----------------------
614 -- Unblock_Interrupt --
615 -----------------------
617 procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
620 end Unblock_Interrupt;
626 function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
632 task body Server_Task is
633 Desc : Handler_Desc renames Descriptors (Interrupt);
634 Self_Id : constant Task_ID := STPO.Self;
635 Temp : Parameterless_Handler;
638 Utilities.Make_Independent;
641 while Interrupt_Count (Interrupt) > 0 loop
642 Interrupt_Count (Interrupt) := Interrupt_Count (Interrupt) - 1;
648 Rendezvous.Call_Simple (Desc.T, Desc.E, Null_Address);
649 when Protected_Procedure =>
658 Initialization.Defer_Abort (Self_Id);
664 STPO.Write_Lock (Self_Id);
665 Self_Id.Common.State := Interrupt_Server_Idle_Sleep;
666 STPO.Sleep (Self_Id, Interrupt_Server_Idle_Sleep);
667 Self_Id.Common.State := Runnable;
668 STPO.Unlock (Self_Id);
674 Initialization.Undefer_Abort (Self_Id);
676 -- Undefer abort here to allow a window for this task
677 -- to be aborted at the time of system shutdown.
682 end System.Interrupts;