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) 1998-2008, Free Software Foundation, Inc. --
11 -- GNARL is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNARL; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNARL was developed by the GNARL team at Florida State University. --
30 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
32 ------------------------------------------------------------------------------
34 -- This is the IRIX & NT version of this package
36 with Ada
.Task_Identification
;
37 with Ada
.Unchecked_Conversion
;
41 with System
.Storage_Elements
;
42 with System
.Task_Primitives
.Operations
;
43 with System
.Tasking
.Utilities
;
44 with System
.Tasking
.Rendezvous
;
45 with System
.Tasking
.Initialization
;
46 with System
.Interrupt_Management
;
47 with System
.Parameters
;
49 package body System
.Interrupts
is
53 use System
.OS_Interface
;
56 package STPO
renames System
.Task_Primitives
.Operations
;
57 package IMNG
renames System
.Interrupt_Management
;
59 subtype int
is Interfaces
.C
.int
;
61 function To_System
is new Ada
.Unchecked_Conversion
62 (Ada
.Task_Identification
.Task_Id
, Task_Id
);
64 type Handler_Kind
is (Unknown
, Task_Entry
, Protected_Procedure
);
66 type Handler_Desc
is record
67 Kind
: Handler_Kind
:= Unknown
;
70 H
: Parameterless_Handler
;
71 Static
: Boolean := False;
74 task type Server_Task
(Interrupt
: Interrupt_ID
) is
75 pragma Interrupt_Priority
(System
.Interrupt_Priority
'Last);
78 type Server_Task_Access
is access Server_Task
;
80 Handlers
: array (Interrupt_ID
) of Task_Id
;
81 Descriptors
: array (Interrupt_ID
) of Handler_Desc
;
82 Interrupt_Count
: array (Interrupt_ID
) of Integer := (others => 0);
84 pragma Volatile_Components
(Interrupt_Count
);
86 procedure Attach_Handler
87 (New_Handler
: Parameterless_Handler
;
88 Interrupt
: Interrupt_ID
;
90 Restoration
: Boolean);
91 -- This internal procedure is needed to finalize protected objects
92 -- that contain interrupt handlers.
94 procedure Signal_Handler
(Sig
: Interrupt_ID
);
95 pragma Convention
(C
, Signal_Handler
);
96 -- This procedure is used to handle all the signals
98 -- Type and Head, Tail of the list containing Registered Interrupt
99 -- Handlers. These definitions are used to register the handlers
100 -- specified by the pragma Interrupt_Handler.
102 --------------------------
103 -- Handler Registration --
104 --------------------------
106 type Registered_Handler
;
107 type R_Link
is access all Registered_Handler
;
109 type Registered_Handler
is record
110 H
: System
.Address
:= System
.Null_Address
;
111 Next
: R_Link
:= null;
114 Registered_Handlers
: R_Link
:= null;
116 function Is_Registered
(Handler
: Parameterless_Handler
) return Boolean;
117 -- See if the Handler has been "pragma"ed using Interrupt_Handler.
118 -- Always consider a null handler as registered.
120 type Handler_Ptr
is access procedure (Sig
: Interrupt_ID
);
121 pragma Convention
(C
, Handler_Ptr
);
123 function TISR
is new Ada
.Unchecked_Conversion
(Handler_Ptr
, isr_address
);
129 procedure Signal_Handler
(Sig
: Interrupt_ID
) is
130 Handler
: Task_Id
renames Handlers
(Sig
);
133 if Intr_Attach_Reset
and then
134 intr_attach
(int
(Sig
), TISR
(Signal_Handler
'Access)) = FUNC_ERR
139 if Handler
/= null then
140 Interrupt_Count
(Sig
) := Interrupt_Count
(Sig
) + 1;
141 STPO
.Wakeup
(Handler
, Interrupt_Server_Idle_Sleep
);
149 function Is_Reserved
(Interrupt
: Interrupt_ID
) return Boolean is
151 return IMNG
.Reserve
(IMNG
.Interrupt_ID
(Interrupt
));
154 -----------------------
155 -- Is_Entry_Attached --
156 -----------------------
158 function Is_Entry_Attached
(Interrupt
: Interrupt_ID
) return Boolean is
160 if Is_Reserved
(Interrupt
) then
161 raise Program_Error
with
162 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
165 return Descriptors
(Interrupt
).T
/= Null_Task
;
166 end Is_Entry_Attached
;
168 -------------------------
169 -- Is_Handler_Attached --
170 -------------------------
172 function Is_Handler_Attached
(Interrupt
: Interrupt_ID
) return Boolean is
174 if Is_Reserved
(Interrupt
) then
175 raise Program_Error
with
176 "Interrupt" & Interrupt_ID
'Image (Interrupt
) & " is reserved";
178 return Descriptors
(Interrupt
).Kind
/= Unknown
;
180 end Is_Handler_Attached
;
186 function Is_Ignored
(Interrupt
: Interrupt_ID
) return Boolean is
196 function Unblocked_By
(Interrupt
: Interrupt_ID
) return Task_Id
is
202 ----------------------
203 -- Ignore_Interrupt --
204 ----------------------
206 procedure Ignore_Interrupt
(Interrupt
: Interrupt_ID
) is
209 end Ignore_Interrupt
;
211 ------------------------
212 -- Unignore_Interrupt --
213 ------------------------
215 procedure Unignore_Interrupt
(Interrupt
: Interrupt_ID
) is
218 end Unignore_Interrupt
;
220 -------------------------------------
221 -- Has_Interrupt_Or_Attach_Handler --
222 -------------------------------------
224 function Has_Interrupt_Or_Attach_Handler
225 (Object
: access Dynamic_Interrupt_Protection
) return Boolean
227 pragma Unreferenced
(Object
);
230 end Has_Interrupt_Or_Attach_Handler
;
236 procedure Finalize
(Object
: in out Static_Interrupt_Protection
) is
238 -- ??? loop to be executed only when we're not doing library level
239 -- finalization, since in this case all interrupt tasks are gone.
241 for N
in reverse Object
.Previous_Handlers
'Range loop
243 (New_Handler
=> Object
.Previous_Handlers
(N
).Handler
,
244 Interrupt
=> Object
.Previous_Handlers
(N
).Interrupt
,
245 Static
=> Object
.Previous_Handlers
(N
).Static
,
246 Restoration
=> True);
249 Tasking
.Protected_Objects
.Entries
.Finalize
250 (Tasking
.Protected_Objects
.Entries
.Protection_Entries
(Object
));
253 -------------------------------------
254 -- Has_Interrupt_Or_Attach_Handler --
255 -------------------------------------
257 function Has_Interrupt_Or_Attach_Handler
258 (Object
: access Static_Interrupt_Protection
) return Boolean
260 pragma Unreferenced
(Object
);
263 end Has_Interrupt_Or_Attach_Handler
;
265 ----------------------
266 -- Install_Handlers --
267 ----------------------
269 procedure Install_Handlers
270 (Object
: access Static_Interrupt_Protection
;
271 New_Handlers
: New_Handler_Array
)
274 for N
in New_Handlers
'Range loop
276 -- We need a lock around this ???
278 Object
.Previous_Handlers
(N
).Interrupt
:= New_Handlers
(N
).Interrupt
;
279 Object
.Previous_Handlers
(N
).Static
:= Descriptors
280 (New_Handlers
(N
).Interrupt
).Static
;
282 -- We call Exchange_Handler and not directly Interrupt_Manager.
283 -- Exchange_Handler so we get the Is_Reserved check.
286 (Old_Handler
=> Object
.Previous_Handlers
(N
).Handler
,
287 New_Handler
=> New_Handlers
(N
).Handler
,
288 Interrupt
=> New_Handlers
(N
).Interrupt
,
291 end Install_Handlers
;
293 ---------------------------------
294 -- Install_Restricted_Handlers --
295 ---------------------------------
297 procedure Install_Restricted_Handlers
(Handlers
: New_Handler_Array
) is
299 for N
in Handlers
'Range loop
300 Attach_Handler
(Handlers
(N
).Handler
, Handlers
(N
).Interrupt
, True);
302 end Install_Restricted_Handlers
;
304 ---------------------
305 -- Current_Handler --
306 ---------------------
308 function Current_Handler
309 (Interrupt
: Interrupt_ID
) return Parameterless_Handler
312 if Is_Reserved
(Interrupt
) then
316 if Descriptors
(Interrupt
).Kind
= Protected_Procedure
then
317 return Descriptors
(Interrupt
).H
;
327 procedure Attach_Handler
328 (New_Handler
: Parameterless_Handler
;
329 Interrupt
: Interrupt_ID
;
330 Static
: Boolean := False) is
332 Attach_Handler
(New_Handler
, Interrupt
, Static
, False);
335 procedure Attach_Handler
336 (New_Handler
: Parameterless_Handler
;
337 Interrupt
: Interrupt_ID
;
339 Restoration
: Boolean)
341 New_Task
: Server_Task_Access
;
344 if Is_Reserved
(Interrupt
) then
348 if not Restoration
and then not Static
350 -- Tries to overwrite a static Interrupt Handler with dynamic handle
353 (Descriptors
(Interrupt
).Static
355 -- New handler not specified as an Interrupt Handler by a pragma
357 or else not Is_Registered
(New_Handler
))
359 raise Program_Error
with
360 "Trying to overwrite a static Interrupt Handler with a " &
364 if Handlers
(Interrupt
) = null then
365 New_Task
:= new Server_Task
(Interrupt
);
366 Handlers
(Interrupt
) := To_System
(New_Task
.all'Identity);
369 if intr_attach
(int
(Interrupt
),
370 TISR
(Signal_Handler
'Access)) = FUNC_ERR
375 if New_Handler
= null then
377 -- The null handler means we are detaching the handler
379 Descriptors
(Interrupt
) :=
380 (Kind
=> Unknown
, T
=> null, E
=> 0, H
=> null, Static
=> False);
383 Descriptors
(Interrupt
).Kind
:= Protected_Procedure
;
384 Descriptors
(Interrupt
).H
:= New_Handler
;
385 Descriptors
(Interrupt
).Static
:= Static
;
389 ----------------------
390 -- Exchange_Handler --
391 ----------------------
393 procedure Exchange_Handler
394 (Old_Handler
: out Parameterless_Handler
;
395 New_Handler
: Parameterless_Handler
;
396 Interrupt
: Interrupt_ID
;
397 Static
: Boolean := False)
400 if Is_Reserved
(Interrupt
) then
404 if Descriptors
(Interrupt
).Kind
= Task_Entry
then
406 -- In case we have an Interrupt Entry already installed.
407 -- raise a program error. (propagate it to the caller).
409 raise Program_Error
with "An interrupt is already installed";
412 Old_Handler
:= Current_Handler
(Interrupt
);
413 Attach_Handler
(New_Handler
, Interrupt
, Static
);
415 end Exchange_Handler
;
421 procedure Detach_Handler
422 (Interrupt
: Interrupt_ID
;
423 Static
: Boolean := False)
426 if Is_Reserved
(Interrupt
) then
430 if Descriptors
(Interrupt
).Kind
= Task_Entry
then
431 raise Program_Error
with "Trying to detach an Interrupt Entry";
434 if not Static
and then Descriptors
(Interrupt
).Static
then
435 raise Program_Error
with
436 "Trying to detach a static Interrupt Handler";
439 Descriptors
(Interrupt
) :=
440 (Kind
=> Unknown
, T
=> null, E
=> 0, H
=> null, Static
=> False);
442 if intr_attach
(int
(Interrupt
), null) = FUNC_ERR
then
451 function Reference
(Interrupt
: Interrupt_ID
) return System
.Address
is
452 Signal
: constant System
.Address
:=
453 System
.Storage_Elements
.To_Address
454 (System
.Storage_Elements
.Integer_Address
(Interrupt
));
457 if Is_Reserved
(Interrupt
) then
459 -- Only usable Interrupts can be used for binding it to an Entry
467 --------------------------------
468 -- Register_Interrupt_Handler --
469 --------------------------------
471 procedure Register_Interrupt_Handler
(Handler_Addr
: System
.Address
) is
473 Registered_Handlers
:=
474 new Registered_Handler
'(H => Handler_Addr, Next => Registered_Handlers);
475 end Register_Interrupt_Handler;
481 -- See if the Handler has been "pragma"ed using Interrupt_Handler.
482 -- Always consider a null handler as registered.
484 function Is_Registered (Handler : Parameterless_Handler) return Boolean is
485 Ptr : R_Link := Registered_Handlers;
487 type Fat_Ptr is record
488 Object_Addr : System.Address;
489 Handler_Addr : System.Address;
492 function To_Fat_Ptr is new Ada.Unchecked_Conversion
493 (Parameterless_Handler, Fat_Ptr);
498 if Handler = null then
502 Fat := To_Fat_Ptr (Handler);
504 while Ptr /= null loop
506 if Ptr.H = Fat.Handler_Addr then
516 -----------------------------
517 -- Bind_Interrupt_To_Entry --
518 -----------------------------
520 procedure Bind_Interrupt_To_Entry
522 E : Task_Entry_Index;
523 Int_Ref : System.Address)
525 Interrupt : constant Interrupt_ID :=
526 Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
528 New_Task : Server_Task_Access;
531 if Is_Reserved (Interrupt) then
535 if Descriptors (Interrupt).Kind /= Unknown then
536 raise Program_Error with
537 "A binding for this interrupt is already present";
540 if Handlers (Interrupt) = null then
541 New_Task := new Server_Task (Interrupt);
542 Handlers (Interrupt) := To_System (New_Task.all'Identity);
545 if intr_attach (int (Interrupt),
546 TISR (Signal_Handler'Access)) = FUNC_ERR
551 Descriptors (Interrupt).Kind := Task_Entry;
552 Descriptors (Interrupt).T := T;
553 Descriptors (Interrupt).E := E;
555 -- Indicate the attachment of Interrupt Entry in ATCB. This is needed so
556 -- that when an Interrupt Entry task terminates the binding can be
557 -- cleaned up. The call to unbinding must be make by the task before it
560 T.Interrupt_Entry := True;
561 end Bind_Interrupt_To_Entry;
563 ------------------------------
564 -- Detach_Interrupt_Entries --
565 ------------------------------
567 procedure Detach_Interrupt_Entries (T : Task_Id) is
569 for J in Interrupt_ID loop
570 if not Is_Reserved (J) then
571 if Descriptors (J).Kind = Task_Entry
572 and then Descriptors (J).T = T
574 Descriptors (J).Kind := Unknown;
576 if intr_attach (int (J), null) = FUNC_ERR then
583 -- Indicate in ATCB that no Interrupt Entries are attached
585 T.Interrupt_Entry := True;
586 end Detach_Interrupt_Entries;
588 ---------------------
589 -- Block_Interrupt --
590 ---------------------
592 procedure Block_Interrupt (Interrupt : Interrupt_ID) is
597 -----------------------
598 -- Unblock_Interrupt --
599 -----------------------
601 procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
604 end Unblock_Interrupt;
610 function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
616 task body Server_Task is
617 Desc : Handler_Desc renames Descriptors (Interrupt);
618 Self_Id : constant Task_Id := STPO.Self;
619 Temp : Parameterless_Handler;
622 Utilities.Make_Independent;
625 while Interrupt_Count (Interrupt) > 0 loop
626 Interrupt_Count (Interrupt) := Interrupt_Count (Interrupt) - 1;
632 Rendezvous.Call_Simple (Desc.T, Desc.E, Null_Address);
633 when Protected_Procedure =>
642 Initialization.Defer_Abort (Self_Id);
648 STPO.Write_Lock (Self_Id);
649 Self_Id.Common.State := Interrupt_Server_Idle_Sleep;
650 STPO.Sleep (Self_Id, Interrupt_Server_Idle_Sleep);
651 Self_Id.Common.State := Runnable;
652 STPO.Unlock (Self_Id);
658 Initialization.Undefer_Abort (Self_Id);
660 -- Undefer abort here to allow a window for this task to be aborted
661 -- at the time of system shutdown.
666 end System.Interrupts;