1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS --
9 -- Copyright (C) 1992-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 a OpenVMS/Alpha version of this package
36 with System
.OS_Interface
;
38 with System
.Parameters
;
40 with System
.Tasking
.Initialization
;
41 with System
.Task_Primitives
;
42 with System
.Task_Primitives
.Operations
;
43 with System
.Task_Primitives
.Operations
.DEC
;
45 with Ada
.Unchecked_Conversion
;
47 package body System
.Interrupt_Management
.Operations
is
49 use System
.OS_Interface
;
50 use System
.Parameters
;
52 use type unsigned_short
;
54 function To_Address
is
55 new Ada
.Unchecked_Conversion
56 (Task_Id
, System
.Task_Primitives
.Task_Address
);
58 package POP
renames System
.Task_Primitives
.Operations
;
60 ----------------------------
61 -- Thread_Block_Interrupt --
62 ----------------------------
64 procedure Thread_Block_Interrupt
(Interrupt
: Interrupt_ID
) is
65 pragma Warnings
(Off
, Interrupt
);
68 end Thread_Block_Interrupt
;
70 ------------------------------
71 -- Thread_Unblock_Interrupt --
72 ------------------------------
74 procedure Thread_Unblock_Interrupt
(Interrupt
: Interrupt_ID
) is
75 pragma Warnings
(Off
, Interrupt
);
78 end Thread_Unblock_Interrupt
;
80 ------------------------
81 -- Set_Interrupt_Mask --
82 ------------------------
84 procedure Set_Interrupt_Mask
(Mask
: access Interrupt_Mask
) is
85 pragma Warnings
(Off
, Mask
);
88 end Set_Interrupt_Mask
;
90 procedure Set_Interrupt_Mask
91 (Mask
: access Interrupt_Mask
;
92 OMask
: access Interrupt_Mask
)
94 pragma Warnings
(Off
, Mask
);
95 pragma Warnings
(Off
, OMask
);
98 end Set_Interrupt_Mask
;
100 ------------------------
101 -- Get_Interrupt_Mask --
102 ------------------------
104 procedure Get_Interrupt_Mask
(Mask
: access Interrupt_Mask
) is
105 pragma Warnings
(Off
, Mask
);
108 end Get_Interrupt_Mask
;
114 function To_unsigned_long
is new
115 Ada
.Unchecked_Conversion
(System
.Aux_DEC
.Short_Address
, unsigned_long
);
117 function Interrupt_Wait
(Mask
: access Interrupt_Mask
)
120 Self_ID
: constant Task_Id
:= Self
;
121 Iosb
: IO_Status_Block_Type
:= (0, 0, 0);
122 Status
: Cond_Value_Type
;
126 -- A QIO read is registered. The system call returns immediately
127 -- after scheduling an AST to be fired when the operation
132 Chan
=> Rcv_Interrupt_Chan
,
136 POP
.DEC
.Interrupt_AST_Handler
'Access,
137 Astprm
=> To_Address
(Self_ID
),
138 P1
=> To_unsigned_long
(Interrupt_Mailbox
'Address),
139 P2
=> Interrupt_ID
'Size / 8);
141 pragma Assert
((Status
and 1) = 1);
145 -- Wait to be woken up. Could be that the AST has fired,
146 -- in which case the Iosb.Status variable will be non-zero,
147 -- or maybe the wait is being aborted.
151 System
.Tasking
.Interrupt_Server_Blocked_On_Event_Flag
);
153 if Iosb
.Status
/= 0 then
154 if (Iosb
.Status
and 1) = 1
155 and then Mask
(Signal
(Interrupt_Mailbox
))
157 return Interrupt_Mailbox
;
162 POP
.Unlock
(Self_ID
);
168 System
.Tasking
.Initialization
.Undefer_Abort
(Self_ID
);
169 System
.Tasking
.Initialization
.Defer_Abort
(Self_ID
);
175 POP
.Write_Lock
(Self_ID
);
180 ----------------------------
181 -- Install_Default_Action --
182 ----------------------------
184 procedure Install_Default_Action
(Interrupt
: Interrupt_ID
) is
185 pragma Warnings
(Off
, Interrupt
);
188 end Install_Default_Action
;
190 ---------------------------
191 -- Install_Ignore_Action --
192 ---------------------------
194 procedure Install_Ignore_Action
(Interrupt
: Interrupt_ID
) is
195 pragma Warnings
(Off
, Interrupt
);
198 end Install_Ignore_Action
;
200 -------------------------
201 -- Fill_Interrupt_Mask --
202 -------------------------
204 procedure Fill_Interrupt_Mask
(Mask
: access Interrupt_Mask
) is
206 Mask
.all := (others => True);
207 end Fill_Interrupt_Mask
;
209 --------------------------
210 -- Empty_Interrupt_Mask --
211 --------------------------
213 procedure Empty_Interrupt_Mask
(Mask
: access Interrupt_Mask
) is
215 Mask
.all := (others => False);
216 end Empty_Interrupt_Mask
;
218 ---------------------------
219 -- Add_To_Interrupt_Mask --
220 ---------------------------
222 procedure Add_To_Interrupt_Mask
223 (Mask
: access Interrupt_Mask
;
224 Interrupt
: Interrupt_ID
)
227 Mask
(Signal
(Interrupt
)) := True;
228 end Add_To_Interrupt_Mask
;
230 --------------------------------
231 -- Delete_From_Interrupt_Mask --
232 --------------------------------
234 procedure Delete_From_Interrupt_Mask
235 (Mask
: access Interrupt_Mask
;
236 Interrupt
: Interrupt_ID
)
239 Mask
(Signal
(Interrupt
)) := False;
240 end Delete_From_Interrupt_Mask
;
247 (Mask
: access Interrupt_Mask
;
248 Interrupt
: Interrupt_ID
) return Boolean
251 return Mask
(Signal
(Interrupt
));
254 -------------------------
255 -- Copy_Interrupt_Mask --
256 -------------------------
258 procedure Copy_Interrupt_Mask
259 (X
: out Interrupt_Mask
;
264 end Copy_Interrupt_Mask
;
266 ----------------------------
267 -- Interrupt_Self_Process --
268 ----------------------------
270 procedure Interrupt_Self_Process
(Interrupt
: Interrupt_ID
) is
271 Status
: Cond_Value_Type
;
275 Chan
=> Snd_Interrupt_Chan
,
276 Func
=> IO_WRITEVBLK
,
277 P1
=> To_unsigned_long
(Interrupt
'Address),
278 P2
=> Interrupt_ID
'Size / 8);
280 -- The following could use a comment ???
282 pragma Assert
((Status
and 1) = 1);
283 end Interrupt_Self_Process
;
285 --------------------------
286 -- Setup_Interrupt_Mask --
287 --------------------------
289 procedure Setup_Interrupt_Mask
is
292 end Setup_Interrupt_Mask
;
295 Interrupt_Management
.Initialize
;
296 Environment_Mask
:= (others => False);
297 All_Tasks_Mask
:= (others => True);
299 for J
in Interrupt_ID
loop
300 if Keep_Unmasked
(J
) then
301 Environment_Mask
(Signal
(J
)) := True;
302 All_Tasks_Mask
(Signal
(J
)) := False;
305 end System
.Interrupt_Management
.Operations
;