projects / gcc.git / blob
? search:


6b0037fe7718da3d67fe00fa6002d996b6fa4ab2
[gcc.git] / gcc / ada / s-interr.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
4 -- --
5 -- S Y S T E M . I N T E R R U P T S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
10 -- --
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. --
21 -- --
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. --
28 -- --
29 -- GNARL was developed by the GNARL team at Florida State University. --
30 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
31 -- --
32 ------------------------------------------------------------------------------
33
34 -- Invariants:
35
36 -- All user-handleable interrupts are masked at all times in all
37 -- tasks/threads except possibly for the Interrupt_Manager task.
38
39 -- When a user task wants to have the effect of masking/unmasking an
40 -- interrupt, it must call Block_Interrupt/Unblock_Interrupt, which
41 -- will have the effect of unmasking/masking the interrupt in the
42 -- Interrupt_Manager task.
43
44 -- Note : Direct calls to sigaction, sigprocmask, pthread_sigsetmask or any
45 -- other low-level interface that changes the interrupt action or
46 -- interrupt mask needs a careful thought.
47 -- One may acheive the effect of system calls first masking RTS blocked
48 -- (by calling Block_Interrupt) for the interrupt under consideration.
49 -- This will make all the tasks in RTS blocked for the Interrupt.
50
51 -- Once we associate a Server_Task with an interrupt, the task never
52 -- goes away, and we never remove the association.
53
54 -- There is no more than one interrupt per Server_Task and no more than
55 -- one Server_Task per interrupt.
56
57 with Ada.Task_Identification;
58 -- used for Task_Id type
59
60 with Ada.Exceptions;
61 -- used for Raise_Exception
62
63 with System.Task_Primitives;
64 -- used for RTS_Lock
65 -- Self
66
67 with System.Interrupt_Management;
68 -- used for Reserve
69 -- Interrupt_ID
70 -- Interrupt_Mask
71 -- Abort_Task_Interrupt
72
73 with System.Interrupt_Management.Operations;
74 -- used for Thread_Block_Interrupt
75 -- Thread_Unblock_Interrupt
76 -- Install_Default_Action
77 -- Install_Ignore_Action
78 -- Copy_Interrupt_Mask
79 -- Set_Interrupt_Mask
80 -- Empty_Interrupt_Mask
81 -- Fill_Interrupt_Mask
82 -- Add_To_Interrupt_Mask
83 -- Delete_From_Interrupt_Mask
84 -- Interrupt_Wait
85 -- Interrupt_Self_Process
86 -- Get_Interrupt_Mask
87 -- Set_Interrupt_Mask
88 -- IS_Member
89 -- Environment_Mask
90 -- All_Tasks_Mask
91 pragma Elaborate_All (System.Interrupt_Management.Operations);
92
93 with System.Task_Primitives.Operations;
94 -- used for Write_Lock
95 -- Unlock
96 -- Abort
97 -- Wakeup_Task
98 -- Sleep
99 -- Initialize_Lock
100
101 with System.Task_Primitives.Interrupt_Operations;
102 -- used for Set_Interrupt_ID
103
104 with System.Storage_Elements;
105 -- used for To_Address
106 -- To_Integer
107 -- Integer_Address
108
109 with System.Tasking.Utilities;
110 -- used for Make_Independent
111
112 with System.Tasking.Rendezvous;
113 -- used for Call_Simple
114 pragma Elaborate_All (System.Tasking.Rendezvous);
115
116 with System.Tasking.Initialization;
117 -- used for Defer_Abort
118 -- Undefer_Abort
119
120 with System.Parameters;
121 -- used for Single_Lock
122
123 with Ada.Unchecked_Conversion;
124
125 package body System.Interrupts is
126
127 use Parameters;
128 use Tasking;
129 use Ada.Exceptions;
130
131 package POP renames System.Task_Primitives.Operations;
132 package PIO renames System.Task_Primitives.Interrupt_Operations;
133 package IMNG renames System.Interrupt_Management;
134 package IMOP renames System.Interrupt_Management.Operations;
135
136 function To_System is new Ada.Unchecked_Conversion
137 (Ada.Task_Identification.Task_Id, Task_Id);
138
139 -----------------
140 -- Local Tasks --
141 -----------------
142
143 -- WARNING: System.Tasking.Stages performs calls to this task
144 -- with low-level constructs. Do not change this spec without synchro-
145 -- nizing it.
146
147 task Interrupt_Manager is
148 entry Detach_Interrupt_Entries (T : Task_Id);
149
150 entry Initialize (Mask : IMNG.Interrupt_Mask);
151
152 entry Attach_Handler
153 (New_Handler : Parameterless_Handler;
154 Interrupt : Interrupt_ID;
155 Static : Boolean;
156 Restoration : Boolean := False);
157
158 entry Exchange_Handler
159 (Old_Handler : out Parameterless_Handler;
160 New_Handler : Parameterless_Handler;
161 Interrupt : Interrupt_ID;
162 Static : Boolean);
163
164 entry Detach_Handler
165 (Interrupt : Interrupt_ID;
166 Static : Boolean);
167
168 entry Bind_Interrupt_To_Entry
169 (T : Task_Id;
170 E : Task_Entry_Index;
171 Interrupt : Interrupt_ID);
172
173 entry Block_Interrupt (Interrupt : Interrupt_ID);
174
175 entry Unblock_Interrupt (Interrupt : Interrupt_ID);
176
177 entry Ignore_Interrupt (Interrupt : Interrupt_ID);
178
179 entry Unignore_Interrupt (Interrupt : Interrupt_ID);
180
181 pragma Interrupt_Priority (System.Interrupt_Priority'Last);
182 end Interrupt_Manager;
183
184 task type Server_Task (Interrupt : Interrupt_ID) is
185 pragma Priority (System.Interrupt_Priority'Last);
186 -- Note: the above pragma Priority is strictly speaking improper
187 -- since it is outside the range of allowed priorities, but the
188 -- compiler treats system units specially and does not apply
189 -- this range checking rule to system units.
190
191 end Server_Task;
192
193 type Server_Task_Access is access Server_Task;
194
195 -------------------------------
196 -- Local Types and Variables --
197 -------------------------------
198
199 type Entry_Assoc is record
200 T : Task_Id;
201 E : Task_Entry_Index;
202 end record;
203
204 type Handler_Assoc is record
205 H : Parameterless_Handler;
206 Static : Boolean; -- Indicates static binding;
207 end record;
208
209 User_Handler : array (Interrupt_ID'Range) of Handler_Assoc :=
210 (others => (null, Static => False));
211 pragma Volatile_Components (User_Handler);
212 -- Holds the protected procedure handler (if any) and its Static
213 -- information for each interrupt. A handler is a Static one if
214 -- it is specified through the pragma Attach_Handler.
215 -- Attach_Handler. Otherwise, not static)
216
217 User_Entry : array (Interrupt_ID'Range) of Entry_Assoc :=
218 (others => (T => Null_Task, E => Null_Task_Entry));
219 pragma Volatile_Components (User_Entry);
220 -- Holds the task and entry index (if any) for each interrupt
221
222 Blocked : array (Interrupt_ID'Range) of Boolean := (others => False);
223 pragma Atomic_Components (Blocked);
224 -- True iff the corresponding interrupt is blocked in the process level
225
226 Ignored : array (Interrupt_ID'Range) of Boolean := (others => False);
227 pragma Atomic_Components (Ignored);
228 -- True iff the corresponding interrupt is blocked in the process level
229
230 Last_Unblocker :
231 array (Interrupt_ID'Range) of Task_Id := (others => Null_Task);
232 pragma Atomic_Components (Last_Unblocker);
233 -- Holds the ID of the last Task which Unblocked this Interrupt.
234 -- It contains Null_Task if no tasks have ever requested the
235 -- Unblocking operation or the Interrupt is currently Blocked.
236
237 Server_ID : array (Interrupt_ID'Range) of Task_Id :=
238 (others => Null_Task);
239 pragma Atomic_Components (Server_ID);
240 -- Holds the Task_Id of the Server_Task for each interrupt.
241 -- Task_Id is needed to accomplish locking per Interrupt base. Also
242 -- is needed to decide whether to create a new Server_Task.
243
244 -- Type and Head, Tail of the list containing Registered Interrupt
245 -- Handlers. These definitions are used to register the handlers
246 -- specified by the pragma Interrupt_Handler.
247
248 type Registered_Handler;
249 type R_Link is access all Registered_Handler;
250
251 type Registered_Handler is record
252 H : System.Address := System.Null_Address;
253 Next : R_Link := null;
254 end record;
255
256 Registered_Handler_Head : R_Link := null;
257 Registered_Handler_Tail : R_Link := null;
258
259 Access_Hold : Server_Task_Access;
260 -- Variable used to allocate Server_Task using "new"
261
262 -----------------------
263 -- Local Subprograms --
264 -----------------------
265
266 function Is_Registered (Handler : Parameterless_Handler) return Boolean;
267 -- See if the Handler has been "pragma"ed using Interrupt_Handler.
268 -- Always consider a null handler as registered.
269
270 --------------------
271 -- Attach_Handler --
272 --------------------
273
274 -- Calling this procedure with New_Handler = null and Static = True
275 -- means we want to detach the current handler regardless of the
276 -- previous handler's binding status (ie. do not care if it is a
277 -- dynamic or static handler).
278
279 -- This option is needed so that during the finalization of a PO, we
280 -- can detach handlers attached through pragma Attach_Handler.
281
282 procedure Attach_Handler
283 (New_Handler : Parameterless_Handler;
284 Interrupt : Interrupt_ID;
285 Static : Boolean := False)
286 is
287 begin
288 if Is_Reserved (Interrupt) then
289 Raise_Exception (Program_Error'Identity, "Interrupt" &
290 Interrupt_ID'Image (Interrupt) & " is reserved");
291 end if;
292
293 Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static);
294
295 end Attach_Handler;
296
297 -----------------------------
298 -- Bind_Interrupt_To_Entry --
299 -----------------------------
300
301 -- This procedure raises a Program_Error if it tries to bind an
302 -- interrupt to which an Entry or a Procedure is already bound.
303
304 procedure Bind_Interrupt_To_Entry
305 (T : Task_Id;
306 E : Task_Entry_Index;
307 Int_Ref : System.Address)
308 is
309 Interrupt : constant Interrupt_ID :=
310 Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
311
312 begin
313 if Is_Reserved (Interrupt) then
314 Raise_Exception (Program_Error'Identity, "Interrupt" &
315 Interrupt_ID'Image (Interrupt) & " is reserved");
316 end if;
317
318 Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt);
319 end Bind_Interrupt_To_Entry;
320
321 ---------------------
322 -- Block_Interrupt --
323 ---------------------
324
325 procedure Block_Interrupt (Interrupt : Interrupt_ID) is
326 begin
327 if Is_Reserved (Interrupt) then
328 Raise_Exception (Program_Error'Identity, "Interrupt" &
329 Interrupt_ID'Image (Interrupt) & " is reserved");
330 end if;
331
332 Interrupt_Manager.Block_Interrupt (Interrupt);
333 end Block_Interrupt;
334
335 ---------------------
336 -- Current_Handler --
337 ---------------------
338
339 function Current_Handler
340 (Interrupt : Interrupt_ID) return Parameterless_Handler
341 is
342 begin
343 if Is_Reserved (Interrupt) then
344 Raise_Exception (Program_Error'Identity, "Interrupt" &
345 Interrupt_ID'Image (Interrupt) & " is reserved");
346 end if;
347
348 -- ??? Since Parameterless_Handler is not Atomic, the current
349 -- implementation is wrong. We need a new service in Interrupt_Manager
350 -- to ensure atomicity.
351
352 return User_Handler (Interrupt).H;
353 end Current_Handler;
354
355 --------------------
356 -- Detach_Handler --
357 --------------------
358
359 -- Calling this procedure with Static = True means we want to Detach the
360 -- current handler regardless of the previous handler's binding status
361 -- (i.e. do not care if it is a dynamic or static handler).
362
363 -- This option is needed so that during the finalization of a PO, we can
364 -- detach handlers attached through pragma Attach_Handler.
365
366 procedure Detach_Handler
367 (Interrupt : Interrupt_ID;
368 Static : Boolean := False)
369 is
370 begin
371 if Is_Reserved (Interrupt) then
372 Raise_Exception (Program_Error'Identity, "Interrupt" &
373 Interrupt_ID'Image (Interrupt) & " is reserved");
374 end if;
375
376 Interrupt_Manager.Detach_Handler (Interrupt, Static);
377 end Detach_Handler;
378
379 ------------------------------
380 -- Detach_Interrupt_Entries --
381 ------------------------------
382
383 procedure Detach_Interrupt_Entries (T : Task_Id) is
384 begin
385 Interrupt_Manager.Detach_Interrupt_Entries (T);
386 end Detach_Interrupt_Entries;
387
388 ----------------------
389 -- Exchange_Handler --
390 ----------------------
391
392 -- Calling this procedure with New_Handler = null and Static = True
393 -- means we want to detach the current handler regardless of the
394 -- previous handler's binding status (ie. do not care if it is a
395 -- dynamic or static handler).
396
397 -- This option is needed so that during the finalization of a PO,
398 -- we can detach handlers attached through pragma Attach_Handler.
399
400 procedure Exchange_Handler
401 (Old_Handler : out Parameterless_Handler;
402 New_Handler : Parameterless_Handler;
403 Interrupt : Interrupt_ID;
404 Static : Boolean := False)
405 is
406 begin
407 if Is_Reserved (Interrupt) then
408 Raise_Exception (Program_Error'Identity, "Interrupt" &
409 Interrupt_ID'Image (Interrupt) & " is reserved");
410 end if;
411
412 Interrupt_Manager.Exchange_Handler
413 (Old_Handler, New_Handler, Interrupt, Static);
414 end Exchange_Handler;
415
416 --------------
417 -- Finalize --
418 --------------
419
420 procedure Finalize (Object : in out Static_Interrupt_Protection) is
421 begin
422 -- ??? loop to be executed only when we're not doing library level
423 -- finalization, since in this case all interrupt tasks are gone.
424
425 if not Interrupt_Manager'Terminated then
426 for N in reverse Object.Previous_Handlers'Range loop
427 Interrupt_Manager.Attach_Handler
428 (New_Handler => Object.Previous_Handlers (N).Handler,
429 Interrupt => Object.Previous_Handlers (N).Interrupt,
430 Static => Object.Previous_Handlers (N).Static,
431 Restoration => True);
432 end loop;
433 end if;
434
435 Tasking.Protected_Objects.Entries.Finalize
436 (Tasking.Protected_Objects.Entries.Protection_Entries (Object));
437 end Finalize;
438
439 -------------------------------------
440 -- Has_Interrupt_Or_Attach_Handler --
441 -------------------------------------
442
443 -- Need comments as to why these always return True ???
444
445 function Has_Interrupt_Or_Attach_Handler
446 (Object : access Dynamic_Interrupt_Protection) return Boolean
447 is
448 pragma Unreferenced (Object);
449 begin
450 return True;
451 end Has_Interrupt_Or_Attach_Handler;
452
453 function Has_Interrupt_Or_Attach_Handler
454 (Object : access Static_Interrupt_Protection) return Boolean
455 is
456 pragma Unreferenced (Object);
457 begin
458 return True;
459 end Has_Interrupt_Or_Attach_Handler;
460
461 ----------------------
462 -- Ignore_Interrupt --
463 ----------------------
464
465 procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
466 begin
467 if Is_Reserved (Interrupt) then
468 Raise_Exception (Program_Error'Identity, "Interrupt" &
469 Interrupt_ID'Image (Interrupt) & " is reserved");
470 end if;
471
472 Interrupt_Manager.Ignore_Interrupt (Interrupt);
473 end Ignore_Interrupt;
474
475 ----------------------
476 -- Install_Handlers --
477 ----------------------
478
479 procedure Install_Handlers
480 (Object : access Static_Interrupt_Protection;
481 New_Handlers : New_Handler_Array)
482 is
483 begin
484 for N in New_Handlers'Range loop
485
486 -- We need a lock around this ???
487
488 Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt;
489 Object.Previous_Handlers (N).Static := User_Handler
490 (New_Handlers (N).Interrupt).Static;
491
492 -- We call Exchange_Handler and not directly Interrupt_Manager.
493 -- Exchange_Handler so we get the Is_Reserved check.
494
495 Exchange_Handler
496 (Old_Handler => Object.Previous_Handlers (N).Handler,
497 New_Handler => New_Handlers (N).Handler,
498 Interrupt => New_Handlers (N).Interrupt,
499 Static => True);
500 end loop;
501 end Install_Handlers;
502
503 ----------------
504 -- Is_Blocked --
505 ----------------
506
507 function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
508 begin
509 if Is_Reserved (Interrupt) then
510 Raise_Exception (Program_Error'Identity, "Interrupt" &
511 Interrupt_ID'Image (Interrupt) & " is reserved");
512 end if;
513
514 return Blocked (Interrupt);
515 end Is_Blocked;
516
517 -----------------------
518 -- Is_Entry_Attached --
519 -----------------------
520
521 function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
522 begin
523 if Is_Reserved (Interrupt) then
524 Raise_Exception (Program_Error'Identity, "Interrupt" &
525 Interrupt_ID'Image (Interrupt) & " is reserved");
526 end if;
527
528 return User_Entry (Interrupt).T /= Null_Task;
529 end Is_Entry_Attached;
530
531 -------------------------
532 -- Is_Handler_Attached --
533 -------------------------
534
535 function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
536 begin
537 if Is_Reserved (Interrupt) then
538 Raise_Exception (Program_Error'Identity, "Interrupt" &
539 Interrupt_ID'Image (Interrupt) & " is reserved");
540 end if;
541
542 return User_Handler (Interrupt).H /= null;
543 end Is_Handler_Attached;
544
545 ----------------
546 -- Is_Ignored --
547 ----------------
548
549 function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
550 begin
551 if Is_Reserved (Interrupt) then
552 Raise_Exception (Program_Error'Identity, "Interrupt" &
553 Interrupt_ID'Image (Interrupt) & " is reserved");
554 end if;
555
556 return Ignored (Interrupt);
557 end Is_Ignored;
558
559 -------------------
560 -- Is_Registered --
561 -------------------
562
563 function Is_Registered (Handler : Parameterless_Handler) return Boolean is
564
565 type Fat_Ptr is record
566 Object_Addr : System.Address;
567 Handler_Addr : System.Address;
568 end record;
569
570 function To_Fat_Ptr is new Ada.Unchecked_Conversion
571 (Parameterless_Handler, Fat_Ptr);
572
573 Ptr : R_Link;
574 Fat : Fat_Ptr;
575
576 begin
577 if Handler = null then
578 return True;
579 end if;
580
581 Fat := To_Fat_Ptr (Handler);
582
583 Ptr := Registered_Handler_Head;
584
585 while Ptr /= null loop
586 if Ptr.H = Fat.Handler_Addr then
587 return True;
588 end if;
589
590 Ptr := Ptr.Next;
591 end loop;
592
593 return False;
594 end Is_Registered;
595
596 -----------------
597 -- Is_Reserved --
598 -----------------
599
600 function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
601 begin
602 return IMNG.Reserve (IMNG.Interrupt_ID (Interrupt));
603 end Is_Reserved;
604
605 ---------------
606 -- Reference --
607 ---------------
608
609 function Reference (Interrupt : Interrupt_ID) return System.Address is
610 begin
611 if Is_Reserved (Interrupt) then
612 Raise_Exception (Program_Error'Identity, "Interrupt" &
613 Interrupt_ID'Image (Interrupt) & " is reserved");
614 end if;
615
616 return Storage_Elements.To_Address
617 (Storage_Elements.Integer_Address (Interrupt));
618 end Reference;
619
620 ---------------------------------
621 -- Register_Interrupt_Handler --
622 ---------------------------------
623
624 procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is
625 New_Node_Ptr : R_Link;
626
627 begin
628 -- This routine registers the Handler as usable for Dynamic Interrupt
629 -- Handler. Routines attaching and detaching Handler dynamically should
630 -- first consult if the Handler is registered. A Program Error should
631 -- be raised if it is not registered.
632
633 -- The pragma Interrupt_Handler can only appear in the library level PO
634 -- definition and instantiation. Therefore, we do not need to implement
635 -- Unregistering operation. Neither we need to protect the queue
636 -- structure using a Lock.
637
638 pragma Assert (Handler_Addr /= System.Null_Address);
639
640 New_Node_Ptr := new Registered_Handler;
641 New_Node_Ptr.H := Handler_Addr;
642
643 if Registered_Handler_Head = null then
644 Registered_Handler_Head := New_Node_Ptr;
645 Registered_Handler_Tail := New_Node_Ptr;
646
647 else
648 Registered_Handler_Tail.Next := New_Node_Ptr;
649 Registered_Handler_Tail := New_Node_Ptr;
650 end if;
651 end Register_Interrupt_Handler;
652
653 -----------------------
654 -- Unblock_Interrupt --
655 -----------------------
656
657 procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
658 begin
659 if Is_Reserved (Interrupt) then
660 Raise_Exception (Program_Error'Identity, "Interrupt" &
661 Interrupt_ID'Image (Interrupt) & " is reserved");
662 end if;
663
664 Interrupt_Manager.Unblock_Interrupt (Interrupt);
665 end Unblock_Interrupt;
666
667 ------------------
668 -- Unblocked_By --
669 ------------------
670
671 function Unblocked_By
672 (Interrupt : Interrupt_ID) return System.Tasking.Task_Id
673 is
674 begin
675 if Is_Reserved (Interrupt) then
676 Raise_Exception (Program_Error'Identity, "Interrupt" &
677 Interrupt_ID'Image (Interrupt) & " is reserved");
678 end if;
679
680 return Last_Unblocker (Interrupt);
681 end Unblocked_By;
682
683 ------------------------
684 -- Unignore_Interrupt --
685 ------------------------
686
687 procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
688 begin
689 if Is_Reserved (Interrupt) then
690 Raise_Exception (Program_Error'Identity, "Interrupt" &
691 Interrupt_ID'Image (Interrupt) & " is reserved");
692 end if;
693
694 Interrupt_Manager.Unignore_Interrupt (Interrupt);
695 end Unignore_Interrupt;
696
697 -----------------------
698 -- Interrupt_Manager --
699 -----------------------
700
701 task body Interrupt_Manager is
702
703 ---------------------
704 -- Local Variables --
705 ---------------------
706
707 Intwait_Mask : aliased IMNG.Interrupt_Mask;
708 Ret_Interrupt : Interrupt_ID;
709 Old_Mask : aliased IMNG.Interrupt_Mask;
710 Old_Handler : Parameterless_Handler;
711
712 --------------------
713 -- Local Routines --
714 --------------------
715
716 procedure Bind_Handler (Interrupt : Interrupt_ID);
717 -- This procedure does not do anything if the Interrupt is blocked.
718 -- Otherwise, we have to interrupt Server_Task for status change through
719 -- Wakeup interrupt.
720
721 procedure Unbind_Handler (Interrupt : Interrupt_ID);
722 -- This procedure does not do anything if the Interrupt is blocked.
723 -- Otherwise, we have to interrupt Server_Task for status change
724 -- through abort interrupt.
725
726 procedure Unprotected_Exchange_Handler
727 (Old_Handler : out Parameterless_Handler;
728 New_Handler : Parameterless_Handler;
729 Interrupt : Interrupt_ID;
730 Static : Boolean;
731 Restoration : Boolean := False);
732
733 procedure Unprotected_Detach_Handler
734 (Interrupt : Interrupt_ID;
735 Static : Boolean);
736
737 ------------------
738 -- Bind_Handler --
739 ------------------
740
741 procedure Bind_Handler (Interrupt : Interrupt_ID) is
742 begin
743 if not Blocked (Interrupt) then
744
745 -- Mask this task for the given Interrupt so that all tasks
746 -- are masked for the Interrupt and the actuall delivery of the
747 -- Interrupt will be caught using "sigwait" by the
748 -- corresponding Server_Task.
749
750 IMOP.Thread_Block_Interrupt (IMNG.Interrupt_ID (Interrupt));
751
752 -- We have installed a Handler or an Entry before we called
753 -- this procedure. If the Handler Task is waiting to be awakened,
754 -- do it here. Otherwise, the interrupt will be discarded.
755
756 POP.Wakeup (Server_ID (Interrupt), Interrupt_Server_Idle_Sleep);
757 end if;
758 end Bind_Handler;
759
760 --------------------
761 -- Unbind_Handler --
762 --------------------
763
764 procedure Unbind_Handler (Interrupt : Interrupt_ID) is
765 Server : System.Tasking.Task_Id;
766 begin
767 if not Blocked (Interrupt) then
768 -- Currently, there is a Handler or an Entry attached and
769 -- corresponding Server_Task is waiting on "sigwait."
770 -- We have to wake up the Server_Task and make it
771 -- wait on condition variable by sending an
772 -- Abort_Task_Interrupt
773
774 Server := Server_ID (Interrupt);
775
776 case Server.Common.State is
777 when Interrupt_Server_Idle_Sleep |
778 Interrupt_Server_Blocked_Interrupt_Sleep
779 =>
780 POP.Wakeup (Server, Server.Common.State);
781
782 when Interrupt_Server_Blocked_On_Event_Flag =>
783 POP.Abort_Task (Server);
784
785 -- Make sure corresponding Server_Task is out of its
786 -- own sigwait state.
787
788 Ret_Interrupt :=
789 Interrupt_ID (IMOP.Interrupt_Wait (Intwait_Mask'Access));
790 pragma Assert
791 (Ret_Interrupt = Interrupt_ID (IMNG.Abort_Task_Interrupt));
792
793 when Runnable =>
794 null;
795
796 when others =>
797 pragma Assert (False);
798 null;
799 end case;
800
801 IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt));
802
803 -- Unmake the Interrupt for this task in order to allow default
804 -- action again.
805
806 IMOP.Thread_Unblock_Interrupt (IMNG.Interrupt_ID (Interrupt));
807
808 else
809 IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt));
810 end if;
811 end Unbind_Handler;
812
813 --------------------------------
814 -- Unprotected_Detach_Handler --
815 --------------------------------
816
817 procedure Unprotected_Detach_Handler
818 (Interrupt : Interrupt_ID;
819 Static : Boolean)
820 is
821 Old_Handler : Parameterless_Handler;
822
823 begin
824 if User_Entry (Interrupt).T /= Null_Task then
825
826 -- In case we have an Interrupt Entry installed.
827 -- raise a program error. (propagate it to the caller).
828
829 Raise_Exception (Program_Error'Identity,
830 "An interrupt entry is already installed");
831 end if;
832
833 -- Note : Static = True will pass the following check. That is the
834 -- case when we want to detach a handler regardless of the static
835 -- status of the current_Handler.
836
837 if not Static and then User_Handler (Interrupt).Static then
838
839 -- Tries to detach a static Interrupt Handler.
840 -- raise a program error.
841
842 Raise_Exception (Program_Error'Identity,
843 "Trying to detach a static Interrupt Handler");
844 end if;
845
846 -- The interrupt should no longer be ignored if
847 -- it was ever ignored.
848
849 Ignored (Interrupt) := False;
850
851 Old_Handler := User_Handler (Interrupt).H;
852
853 -- The new handler
854
855 User_Handler (Interrupt).H := null;
856 User_Handler (Interrupt).Static := False;
857
858 if Old_Handler /= null then
859 Unbind_Handler (Interrupt);
860 end if;
861 end Unprotected_Detach_Handler;
862
863 ----------------------------------
864 -- Unprotected_Exchange_Handler --
865 ----------------------------------
866
867 procedure Unprotected_Exchange_Handler
868 (Old_Handler : out Parameterless_Handler;
869 New_Handler : Parameterless_Handler;
870 Interrupt : Interrupt_ID;
871 Static : Boolean;
872 Restoration : Boolean := False)
873 is
874 begin
875 if User_Entry (Interrupt).T /= Null_Task then
876
877 -- In case we have an Interrupt Entry already installed.
878 -- raise a program error. (propagate it to the caller).
879
880 Raise_Exception (Program_Error'Identity,
881 "An interrupt is already installed");
882 end if;
883
884 -- Note : A null handler with Static = True will pass the
885 -- following check. That is the case when we want to Detach a
886 -- handler regardless of the Static status of the current_Handler.
887
888 -- We don't check anything if Restoration is True, since we
889 -- may be detaching a static handler to restore a dynamic one.
890
891 if not Restoration and then not Static
892
893 -- Tries to overwrite a static Interrupt Handler with a
894 -- dynamic Handler
895
896 and then (User_Handler (Interrupt).Static
897
898 -- The new handler is not specified as an
899 -- Interrupt Handler by a pragma.
900
901 or else not Is_Registered (New_Handler))
902 then
903 Raise_Exception (Program_Error'Identity,
904 "Trying to overwrite a static Interrupt Handler with a " &
905 "dynamic Handler");
906 end if;
907
908 -- The interrupt should no longer be ingnored if
909 -- it was ever ignored.
910
911 Ignored (Interrupt) := False;
912
913 -- Save the old handler
914
915 Old_Handler := User_Handler (Interrupt).H;
916
917 -- The new handler
918
919 User_Handler (Interrupt).H := New_Handler;
920
921 if New_Handler = null then
922
923 -- The null handler means we are detaching the handler
924
925 User_Handler (Interrupt).Static := False;
926
927 else
928 User_Handler (Interrupt).Static := Static;
929 end if;
930
931 -- Invoke a corresponding Server_Task if not yet created.
932 -- Place Task_Id info in Server_ID array.
933
934 if Server_ID (Interrupt) = Null_Task then
935
936 -- When a new Server_Task is created, it should have its
937 -- signal mask set to the All_Tasks_Mask.
938
939 IMOP.Set_Interrupt_Mask
940 (IMOP.All_Tasks_Mask'Access, Old_Mask'Access);
941 Access_Hold := new Server_Task (Interrupt);
942 IMOP.Set_Interrupt_Mask (Old_Mask'Access);
943
944 Server_ID (Interrupt) := To_System (Access_Hold.all'Identity);
945 end if;
946
947 if New_Handler = null then
948 if Old_Handler /= null then
949 Unbind_Handler (Interrupt);
950 end if;
951
952 return;
953 end if;
954
955 if Old_Handler = null then
956 Bind_Handler (Interrupt);
957 end if;
958 end Unprotected_Exchange_Handler;
959
960 -- Start of processing for Interrupt_Manager
961
962 begin
963 -- By making this task independent of master, when the process
964 -- goes away, the Interrupt_Manager will terminate gracefully.
965
966 System.Tasking.Utilities.Make_Independent;
967
968 -- Environment task gets its own interrupt mask, saves it,
969 -- and then masks all interrupts except the Keep_Unmasked set.
970
971 -- During rendezvous, the Interrupt_Manager receives the old
972 -- interrupt mask of the environment task, and sets its own
973 -- interrupt mask to that value.
974
975 -- The environment task will call the entry of Interrupt_Manager some
976 -- during elaboration of the body of this package.
977
978 accept Initialize (Mask : IMNG.Interrupt_Mask) do
979 declare
980 The_Mask : aliased IMNG.Interrupt_Mask;
981
982 begin
983 IMOP.Copy_Interrupt_Mask (The_Mask, Mask);
984 IMOP.Set_Interrupt_Mask (The_Mask'Access);
985 end;
986 end Initialize;
987
988 -- Note: All tasks in RTS will have all the Reserve Interrupts
989 -- being masked (except the Interrupt_Manager) and Keep_Unmasked
990 -- unmasked when created.
991
992 -- Abort_Task_Interrupt is one of the Interrupt unmasked
993 -- in all tasks. We mask the Interrupt in this particular task
994 -- so that "sigwait" is possible to catch an explicitely sent
995 -- Abort_Task_Interrupt from the Server_Tasks.
996
997 -- This sigwaiting is needed so that we make sure a Server_Task is
998 -- out of its own sigwait state. This extra synchronization is
999 -- necessary to prevent following senarios.
1000
1001 -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to the
1002 -- Server_Task then changes its own interrupt mask (OS level).
1003 -- If an interrupt (corresponding to the Server_Task) arrives
1004 -- in the nean time we have the Interrupt_Manager umnasked and
1005 -- the Server_Task waiting on sigwait.
1006
1007 -- 2) For unbinding handler, we install a default action in the
1008 -- Interrupt_Manager. POSIX.1c states that the result of using
1009 -- "sigwait" and "sigaction" simaltaneously on the same interrupt
1010 -- is undefined. Therefore, we need to be informed from the
1011 -- Server_Task of the fact that the Server_Task is out of its
1012 -- sigwait stage.
1013
1014 IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access);
1015 IMOP.Add_To_Interrupt_Mask
1016 (Intwait_Mask'Access, IMNG.Abort_Task_Interrupt);
1017 IMOP.Thread_Block_Interrupt
1018 (IMNG.Abort_Task_Interrupt);
1019
1020 loop
1021 -- A block is needed to absorb Program_Error exception
1022
1023 begin
1024 select
1025 accept Attach_Handler
1026 (New_Handler : Parameterless_Handler;
1027 Interrupt : Interrupt_ID;
1028 Static : Boolean;
1029 Restoration : Boolean := False)
1030 do
1031 Unprotected_Exchange_Handler
1032 (Old_Handler, New_Handler, Interrupt, Static, Restoration);
1033 end Attach_Handler;
1034
1035 or
1036 accept Exchange_Handler
1037 (Old_Handler : out Parameterless_Handler;
1038 New_Handler : Parameterless_Handler;
1039 Interrupt : Interrupt_ID;
1040 Static : Boolean)
1041 do
1042 Unprotected_Exchange_Handler
1043 (Old_Handler, New_Handler, Interrupt, Static);
1044 end Exchange_Handler;
1045
1046 or
1047 accept Detach_Handler
1048 (Interrupt : Interrupt_ID;
1049 Static : Boolean)
1050 do
1051 Unprotected_Detach_Handler (Interrupt, Static);
1052 end Detach_Handler;
1053
1054 or
1055 accept Bind_Interrupt_To_Entry
1056 (T : Task_Id;
1057 E : Task_Entry_Index;
1058 Interrupt : Interrupt_ID)
1059 do
1060 -- if there is a binding already (either a procedure or an
1061 -- entry), raise Program_Error (propagate it to the caller).
1062
1063 if User_Handler (Interrupt).H /= null
1064 or else User_Entry (Interrupt).T /= Null_Task
1065 then
1066 Raise_Exception (Program_Error'Identity,
1067 "A binding for this interrupt is already present");
1068 end if;
1069
1070 -- The interrupt should no longer be ingnored if
1071 -- it was ever ignored.
1072
1073 Ignored (Interrupt) := False;
1074 User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E);
1075
1076 -- Indicate the attachment of Interrupt Entry in ATCB.
1077 -- This is need so that when an Interrupt Entry task
1078 -- terminates the binding can be cleaned. The call to
1079 -- unbinding must be made by the task before it terminates.
1080
1081 T.Interrupt_Entry := True;
1082
1083 -- Invoke a corresponding Server_Task if not yet created.
1084 -- Place Task_Id info in Server_ID array.
1085
1086 if Server_ID (Interrupt) = Null_Task then
1087
1088 -- When a new Server_Task is created, it should have its
1089 -- signal mask set to the All_Tasks_Mask.
1090
1091 IMOP.Set_Interrupt_Mask
1092 (IMOP.All_Tasks_Mask'Access, Old_Mask'Access);
1093 Access_Hold := new Server_Task (Interrupt);
1094 IMOP.Set_Interrupt_Mask (Old_Mask'Access);
1095 Server_ID (Interrupt) :=
1096 To_System (Access_Hold.all'Identity);
1097 end if;
1098
1099 Bind_Handler (Interrupt);
1100 end Bind_Interrupt_To_Entry;
1101
1102 or
1103 accept Detach_Interrupt_Entries (T : Task_Id) do
1104 for J in Interrupt_ID'Range loop
1105 if not Is_Reserved (J) then
1106 if User_Entry (J).T = T then
1107
1108 -- The interrupt should no longer be ingnored if
1109 -- it was ever ignored.
1110
1111 Ignored (J) := False;
1112 User_Entry (J) := Entry_Assoc'
1113 (T => Null_Task, E => Null_Task_Entry);
1114 Unbind_Handler (J);
1115 end if;
1116 end if;
1117 end loop;
1118
1119 -- Indicate in ATCB that no Interrupt Entries are attached
1120
1121 T.Interrupt_Entry := False;
1122 end Detach_Interrupt_Entries;
1123
1124 or
1125 accept Block_Interrupt (Interrupt : Interrupt_ID) do
1126 if Blocked (Interrupt) then
1127 return;
1128 end if;
1129
1130 Blocked (Interrupt) := True;
1131 Last_Unblocker (Interrupt) := Null_Task;
1132
1133 -- Mask this task for the given Interrupt so that all tasks
1134 -- are masked for the Interrupt.
1135
1136 IMOP.Thread_Block_Interrupt (IMNG.Interrupt_ID (Interrupt));
1137
1138 if User_Handler (Interrupt).H /= null
1139 or else User_Entry (Interrupt).T /= Null_Task
1140 then
1141 -- This is the case where the Server_Task is waiting
1142 -- on "sigwait." Wake it up by sending an
1143 -- Abort_Task_Interrupt so that the Server_Task
1144 -- waits on Cond.
1145
1146 POP.Abort_Task (Server_ID (Interrupt));
1147
1148 -- Make sure corresponding Server_Task is out of its own
1149 -- sigwait state.
1150
1151 Ret_Interrupt := Interrupt_ID
1152 (IMOP.Interrupt_Wait (Intwait_Mask'Access));
1153 pragma Assert
1154 (Ret_Interrupt =
1155 Interrupt_ID (IMNG.Abort_Task_Interrupt));
1156 end if;
1157 end Block_Interrupt;
1158
1159 or
1160 accept Unblock_Interrupt (Interrupt : Interrupt_ID) do
1161 if not Blocked (Interrupt) then
1162 return;
1163 end if;
1164
1165 Blocked (Interrupt) := False;
1166 Last_Unblocker (Interrupt) :=
1167 To_System (Unblock_Interrupt'Caller);
1168
1169 if User_Handler (Interrupt).H = null
1170 and then User_Entry (Interrupt).T = Null_Task
1171 then
1172 -- No handler is attached. Unmask the Interrupt so that
1173 -- the default action can be carried out.
1174
1175 IMOP.Thread_Unblock_Interrupt
1176 (IMNG.Interrupt_ID (Interrupt));
1177
1178 else
1179 -- The Server_Task must be waiting on the Cond variable
1180 -- since it was being blocked and an Interrupt Hander or
1181 -- an Entry was there. Wake it up and let it change
1182 -- it place of waiting according to its new state.
1183
1184 POP.Wakeup (Server_ID (Interrupt),
1185 Interrupt_Server_Blocked_Interrupt_Sleep);
1186 end if;
1187 end Unblock_Interrupt;
1188
1189 or
1190 accept Ignore_Interrupt (Interrupt : Interrupt_ID) do
1191 if Ignored (Interrupt) then
1192 return;
1193 end if;
1194
1195 Ignored (Interrupt) := True;
1196
1197 -- If there is a handler associated with the Interrupt,
1198 -- detach it first. In this way we make sure that the
1199 -- Server_Task is not on sigwait. This is legal since
1200 -- Unignore_Interrupt is to install the default action.
1201
1202 if User_Handler (Interrupt).H /= null then
1203 Unprotected_Detach_Handler
1204 (Interrupt => Interrupt, Static => True);
1205
1206 elsif User_Entry (Interrupt).T /= Null_Task then
1207 User_Entry (Interrupt) := Entry_Assoc'
1208 (T => Null_Task, E => Null_Task_Entry);
1209 Unbind_Handler (Interrupt);
1210 end if;
1211
1212 IMOP.Install_Ignore_Action (IMNG.Interrupt_ID (Interrupt));
1213 end Ignore_Interrupt;
1214
1215 or
1216 accept Unignore_Interrupt (Interrupt : Interrupt_ID) do
1217 Ignored (Interrupt) := False;
1218
1219 -- If there is a handler associated with the Interrupt,
1220 -- detach it first. In this way we make sure that the
1221 -- Server_Task is not on sigwait. This is legal since
1222 -- Unignore_Interrupt is to install the default action.
1223
1224 if User_Handler (Interrupt).H /= null then
1225 Unprotected_Detach_Handler
1226 (Interrupt => Interrupt, Static => True);
1227
1228 elsif User_Entry (Interrupt).T /= Null_Task then
1229 User_Entry (Interrupt) := Entry_Assoc'
1230 (T => Null_Task, E => Null_Task_Entry);
1231 Unbind_Handler (Interrupt);
1232 end if;
1233
1234 IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt));
1235 end Unignore_Interrupt;
1236 end select;
1237
1238 exception
1239 -- If there is a program error we just want to propagate it to
1240 -- the caller and do not want to stop this task.
1241
1242 when Program_Error =>
1243 null;
1244
1245 when others =>
1246 pragma Assert (False);
1247 null;
1248 end;
1249 end loop;
1250 end Interrupt_Manager;
1251
1252 -----------------
1253 -- Server_Task --
1254 -----------------
1255
1256 task body Server_Task is
1257 Intwait_Mask : aliased IMNG.Interrupt_Mask;
1258 Ret_Interrupt : Interrupt_ID;
1259 Self_ID : constant Task_Id := Self;
1260 Tmp_Handler : Parameterless_Handler;
1261 Tmp_ID : Task_Id;
1262 Tmp_Entry_Index : Task_Entry_Index;
1263
1264 begin
1265 -- By making this task independent of master, when the process
1266 -- goes away, the Server_Task will terminate gracefully.
1267
1268 System.Tasking.Utilities.Make_Independent;
1269
1270 -- Install default action in system level
1271
1272 IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt));
1273
1274 -- Note: All tasks in RTS will have all the Reserve Interrupts being
1275 -- masked (except the Interrupt_Manager) and Keep_Unmasked unmasked when
1276 -- created.
1277
1278 -- Abort_Task_Interrupt is one of the Interrupt unmasked in all tasks.
1279 -- We mask the Interrupt in this particular task so that "sigwait" is
1280 -- possible to catch an explicitely sent Abort_Task_Interrupt from the
1281 -- Interrupt_Manager.
1282
1283 -- There are two Interrupt interrupts that this task catch through
1284 -- "sigwait." One is the Interrupt this task is designated to catch
1285 -- in order to execure user handler or entry. The other one is the
1286 -- Abort_Task_Interrupt. This interrupt is being sent from the
1287 -- Interrupt_Manager to inform status changes (e.g: become Blocked,
1288 -- Handler or Entry is to be detached).
1289
1290 -- Prepare a mask to used for sigwait
1291
1292 IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access);
1293
1294 IMOP.Add_To_Interrupt_Mask
1295 (Intwait_Mask'Access, IMNG.Interrupt_ID (Interrupt));
1296
1297 IMOP.Add_To_Interrupt_Mask
1298 (Intwait_Mask'Access, IMNG.Abort_Task_Interrupt);
1299
1300 IMOP.Thread_Block_Interrupt
1301 (IMNG.Abort_Task_Interrupt);
1302
1303 PIO.Set_Interrupt_ID (IMNG.Interrupt_ID (Interrupt), Self_ID);
1304
1305 loop
1306 System.Tasking.Initialization.Defer_Abort (Self_ID);
1307
1308 if Single_Lock then
1309 POP.Lock_RTS;
1310 end if;
1311
1312 POP.Write_Lock (Self_ID);
1313
1314 if User_Handler (Interrupt).H = null
1315 and then User_Entry (Interrupt).T = Null_Task
1316 then
1317 -- No Interrupt binding. If there is an interrupt,
1318 -- Interrupt_Manager will take default action.
1319
1320 Self_ID.Common.State := Interrupt_Server_Blocked_Interrupt_Sleep;
1321 POP.Sleep (Self_ID, Interrupt_Server_Idle_Sleep);
1322 Self_ID.Common.State := Runnable;
1323
1324 elsif Blocked (Interrupt) then
1325
1326 -- Interrupt is blocked. Stay here, so we won't catch
1327 -- the Interrupt.
1328
1329 Self_ID.Common.State := Interrupt_Server_Blocked_Interrupt_Sleep;
1330 POP.Sleep (Self_ID, Interrupt_Server_Blocked_Interrupt_Sleep);
1331 Self_ID.Common.State := Runnable;
1332
1333 else
1334 -- A Handler or an Entry is installed. At this point all tasks
1335 -- mask for the Interrupt is masked. Catch the Interrupt using
1336 -- sigwait.
1337
1338 -- This task may wake up from sigwait by receiving an interrupt
1339 -- (Abort_Task_Interrupt) from the Interrupt_Manager for unbinding
1340 -- a Procedure Handler or an Entry. Or it could be a wake up
1341 -- from status change (Unblocked -> Blocked). If that is not
1342 -- the case, we should exceute the attached Procedure or Entry.
1343
1344 Self_ID.Common.State := Interrupt_Server_Blocked_On_Event_Flag;
1345 POP.Unlock (Self_ID);
1346
1347 if Single_Lock then
1348 POP.Unlock_RTS;
1349 end if;
1350
1351 -- Avoid race condition when terminating application and
1352 -- System.Parameters.No_Abort is True.
1353
1354 if Parameters.No_Abort and then Self_ID.Pending_Action then
1355 Initialization.Do_Pending_Action (Self_ID);
1356 end if;
1357
1358 Ret_Interrupt :=
1359 Interrupt_ID (IMOP.Interrupt_Wait (Intwait_Mask'Access));
1360 Self_ID.Common.State := Runnable;
1361
1362 if Ret_Interrupt = Interrupt_ID (IMNG.Abort_Task_Interrupt) then
1363
1364 -- Inform the Interrupt_Manager of wakeup from above sigwait
1365
1366 POP.Abort_Task (Interrupt_Manager_ID);
1367
1368 if Single_Lock then
1369 POP.Lock_RTS;
1370 end if;
1371
1372 POP.Write_Lock (Self_ID);
1373
1374 else
1375 if Single_Lock then
1376 POP.Lock_RTS;
1377 end if;
1378
1379 POP.Write_Lock (Self_ID);
1380
1381 if Ret_Interrupt /= Interrupt then
1382
1383 -- On some systems (e.g. recent linux kernels), sigwait
1384 -- may return unexpectedly (with errno set to EINTR).
1385
1386 null;
1387
1388 else
1389 -- Even though we have received an Interrupt the status may
1390 -- have changed already before we got the Self_ID lock above
1391 -- Therefore we make sure a Handler or an Entry is still
1392 -- there and make appropriate call.
1393
1394 -- If there is no calls to make we need to regenerate the
1395 -- Interrupt in order not to lose it.
1396
1397 if User_Handler (Interrupt).H /= null then
1398 Tmp_Handler := User_Handler (Interrupt).H;
1399
1400 -- RTS calls should not be made with self being locked
1401
1402 POP.Unlock (Self_ID);
1403
1404 if Single_Lock then
1405 POP.Unlock_RTS;
1406 end if;
1407
1408 Tmp_Handler.all;
1409
1410 if Single_Lock then
1411 POP.Lock_RTS;
1412 end if;
1413
1414 POP.Write_Lock (Self_ID);
1415
1416 elsif User_Entry (Interrupt).T /= Null_Task then
1417 Tmp_ID := User_Entry (Interrupt).T;
1418 Tmp_Entry_Index := User_Entry (Interrupt).E;
1419
1420 -- RTS calls should not be made with self being locked
1421
1422 if Single_Lock then
1423 POP.Unlock_RTS;
1424 end if;
1425
1426 POP.Unlock (Self_ID);
1427
1428 System.Tasking.Rendezvous.Call_Simple
1429 (Tmp_ID, Tmp_Entry_Index, System.Null_Address);
1430
1431 POP.Write_Lock (Self_ID);
1432
1433 if Single_Lock then
1434 POP.Lock_RTS;
1435 end if;
1436
1437 else
1438 -- This is a situation that this task wakes up receiving
1439 -- an Interrupt and before it gets the lock the Interrupt
1440 -- is blocked. We do not want to lose the interrupt in
1441 -- this case so we regenerate the Interrupt to process
1442 -- level.
1443
1444 IMOP.Interrupt_Self_Process
1445 (IMNG.Interrupt_ID (Interrupt));
1446 end if;
1447 end if;
1448 end if;
1449 end if;
1450
1451 POP.Unlock (Self_ID);
1452
1453 if Single_Lock then
1454 POP.Unlock_RTS;
1455 end if;
1456
1457 System.Tasking.Initialization.Undefer_Abort (Self_ID);
1458
1459 if Self_ID.Pending_Action then
1460 Initialization.Do_Pending_Action (Self_ID);
1461 end if;
1462
1463 -- Undefer abort here to allow a window for this task to be aborted
1464 -- at the time of system shutdown. We also explicitely test for
1465 -- Pending_Action in case System.Parameters.No_Abort is True.
1466
1467 end loop;
1468 end Server_Task;
1469
1470 -- Elaboration code for package System.Interrupts
1471
1472 begin
1473 -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent
1474
1475 Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity);
1476
1477 -- During the elaboration of this package body we want the RTS
1478 -- to inherit the interrupt mask from the Environment Task.
1479
1480 IMOP.Setup_Interrupt_Mask;
1481
1482 -- The environment task should have gotten its mask from the enclosing
1483 -- process during the RTS start up. (See processing in s-inmaop.adb). Pass
1484 -- the Interrupt_Mask of the environment task to the Interrupt_Manager.
1485
1486 -- Note: At this point we know that all tasks are masked for non-reserved
1487 -- signals. Only the Interrupt_Manager will have masks set up differently
1488 -- inheriting the original environment task's mask.
1489
1490 Interrupt_Manager.Initialize (IMOP.Environment_Mask);
1491 end System.Interrupts;