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) 1998-2018, 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 3, or (at your option) any later ver- -- 14-- sion. GNAT 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. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNARL was developed by the GNARL team at Florida State University. -- 28-- Extensive contributions were provided by Ada Core Technologies, Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32-- This is the NT version of this package 33 34with Ada.Task_Identification; 35with Ada.Unchecked_Conversion; 36 37with Interfaces.C; 38 39with System.Storage_Elements; 40with System.Task_Primitives.Operations; 41with System.Tasking.Utilities; 42with System.Tasking.Rendezvous; 43with System.Tasking.Initialization; 44with System.Interrupt_Management; 45with System.Parameters; 46 47package body System.Interrupts is 48 49 use Parameters; 50 use Tasking; 51 use System.OS_Interface; 52 use Interfaces.C; 53 54 package STPO renames System.Task_Primitives.Operations; 55 package IMNG renames System.Interrupt_Management; 56 57 subtype int is Interfaces.C.int; 58 59 function To_System is new Ada.Unchecked_Conversion 60 (Ada.Task_Identification.Task_Id, Task_Id); 61 62 type Handler_Kind is (Unknown, Task_Entry, Protected_Procedure); 63 64 type Handler_Desc is record 65 Kind : Handler_Kind := Unknown; 66 T : Task_Id; 67 E : Task_Entry_Index; 68 H : Parameterless_Handler; 69 Static : Boolean := False; 70 end record; 71 72 task type Server_Task (Interrupt : Interrupt_ID) is 73 pragma Interrupt_Priority (System.Interrupt_Priority'Last); 74 end Server_Task; 75 76 type Server_Task_Access is access Server_Task; 77 78 Handlers : array (Interrupt_ID) of Task_Id; 79 Descriptors : array (Interrupt_ID) of Handler_Desc; 80 Interrupt_Count : array (Interrupt_ID) of Integer := (others => 0); 81 82 pragma Volatile_Components (Interrupt_Count); 83 84 procedure Attach_Handler 85 (New_Handler : Parameterless_Handler; 86 Interrupt : Interrupt_ID; 87 Static : Boolean; 88 Restoration : Boolean); 89 -- This internal procedure is needed to finalize protected objects that 90 -- contain interrupt handlers. 91 92 procedure Signal_Handler (Sig : Interrupt_ID); 93 pragma Convention (C, Signal_Handler); 94 -- This procedure is used to handle all the signals 95 96 -- Type and Head, Tail of the list containing Registered Interrupt 97 -- Handlers. These definitions are used to register the handlers 98 -- specified by the pragma Interrupt_Handler. 99 100 -------------------------- 101 -- Handler Registration -- 102 -------------------------- 103 104 type Registered_Handler; 105 type R_Link is access all Registered_Handler; 106 107 type Registered_Handler is record 108 H : System.Address := System.Null_Address; 109 Next : R_Link := null; 110 end record; 111 112 Registered_Handlers : R_Link := null; 113 114 function Is_Registered (Handler : Parameterless_Handler) return Boolean; 115 -- See if the Handler has been "pragma"ed using Interrupt_Handler. 116 -- Always consider a null handler as registered. 117 118 type Handler_Ptr is access procedure (Sig : Interrupt_ID); 119 pragma Convention (C, Handler_Ptr); 120 121 function TISR is new Ada.Unchecked_Conversion (Handler_Ptr, isr_address); 122 123 -------------------- 124 -- Signal_Handler -- 125 -------------------- 126 127 procedure Signal_Handler (Sig : Interrupt_ID) is 128 Handler : Task_Id renames Handlers (Sig); 129 130 begin 131 if Intr_Attach_Reset and then 132 intr_attach (int (Sig), TISR (Signal_Handler'Access)) = FUNC_ERR 133 then 134 raise Program_Error; 135 end if; 136 137 if Handler /= null then 138 Interrupt_Count (Sig) := Interrupt_Count (Sig) + 1; 139 STPO.Wakeup (Handler, Interrupt_Server_Idle_Sleep); 140 end if; 141 end Signal_Handler; 142 143 ----------------- 144 -- Is_Reserved -- 145 ----------------- 146 147 function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is 148 begin 149 return IMNG.Reserve (IMNG.Interrupt_ID (Interrupt)); 150 end Is_Reserved; 151 152 ----------------------- 153 -- Is_Entry_Attached -- 154 ----------------------- 155 156 function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is 157 begin 158 if Is_Reserved (Interrupt) then 159 raise Program_Error with 160 "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; 161 end if; 162 163 return Descriptors (Interrupt).T /= Null_Task; 164 end Is_Entry_Attached; 165 166 ------------------------- 167 -- Is_Handler_Attached -- 168 ------------------------- 169 170 function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is 171 begin 172 if Is_Reserved (Interrupt) then 173 raise Program_Error with 174 "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; 175 else 176 return Descriptors (Interrupt).Kind /= Unknown; 177 end if; 178 end Is_Handler_Attached; 179 180 ---------------- 181 -- Is_Ignored -- 182 ---------------- 183 184 function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is 185 begin 186 raise Program_Error; 187 return False; 188 end Is_Ignored; 189 190 ------------------ 191 -- Unblocked_By -- 192 ------------------ 193 194 function Unblocked_By (Interrupt : Interrupt_ID) return Task_Id is 195 begin 196 raise Program_Error; 197 return Null_Task; 198 end Unblocked_By; 199 200 ---------------------- 201 -- Ignore_Interrupt -- 202 ---------------------- 203 204 procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is 205 begin 206 raise Program_Error; 207 end Ignore_Interrupt; 208 209 ------------------------ 210 -- Unignore_Interrupt -- 211 ------------------------ 212 213 procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is 214 begin 215 raise Program_Error; 216 end Unignore_Interrupt; 217 218 ------------------------------------- 219 -- Has_Interrupt_Or_Attach_Handler -- 220 ------------------------------------- 221 222 function Has_Interrupt_Or_Attach_Handler 223 (Object : access Dynamic_Interrupt_Protection) return Boolean 224 is 225 pragma Unreferenced (Object); 226 begin 227 return True; 228 end Has_Interrupt_Or_Attach_Handler; 229 230 -------------- 231 -- Finalize -- 232 -------------- 233 234 procedure Finalize (Object : in out Static_Interrupt_Protection) is 235 begin 236 -- ??? loop to be executed only when we're not doing library level 237 -- finalization, since in this case all interrupt tasks are gone. 238 239 for N in reverse Object.Previous_Handlers'Range loop 240 Attach_Handler 241 (New_Handler => Object.Previous_Handlers (N).Handler, 242 Interrupt => Object.Previous_Handlers (N).Interrupt, 243 Static => Object.Previous_Handlers (N).Static, 244 Restoration => True); 245 end loop; 246 247 Tasking.Protected_Objects.Entries.Finalize 248 (Tasking.Protected_Objects.Entries.Protection_Entries (Object)); 249 end Finalize; 250 251 ------------------------------------- 252 -- Has_Interrupt_Or_Attach_Handler -- 253 ------------------------------------- 254 255 function Has_Interrupt_Or_Attach_Handler 256 (Object : access Static_Interrupt_Protection) return Boolean 257 is 258 pragma Unreferenced (Object); 259 begin 260 return True; 261 end Has_Interrupt_Or_Attach_Handler; 262 263 ---------------------- 264 -- Install_Handlers -- 265 ---------------------- 266 267 procedure Install_Handlers 268 (Object : access Static_Interrupt_Protection; 269 New_Handlers : New_Handler_Array) 270 is 271 begin 272 for N in New_Handlers'Range loop 273 274 -- We need a lock around this ??? 275 276 Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt; 277 Object.Previous_Handlers (N).Static := Descriptors 278 (New_Handlers (N).Interrupt).Static; 279 280 -- We call Exchange_Handler and not directly Interrupt_Manager. 281 -- Exchange_Handler so we get the Is_Reserved check. 282 283 Exchange_Handler 284 (Old_Handler => Object.Previous_Handlers (N).Handler, 285 New_Handler => New_Handlers (N).Handler, 286 Interrupt => New_Handlers (N).Interrupt, 287 Static => True); 288 end loop; 289 end Install_Handlers; 290 291 --------------------------------- 292 -- Install_Restricted_Handlers -- 293 --------------------------------- 294 295 procedure Install_Restricted_Handlers 296 (Prio : Any_Priority; 297 Handlers : New_Handler_Array) 298 is 299 pragma Unreferenced (Prio); 300 begin 301 for N in Handlers'Range loop 302 Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True); 303 end loop; 304 end Install_Restricted_Handlers; 305 306 --------------------- 307 -- Current_Handler -- 308 --------------------- 309 310 function Current_Handler 311 (Interrupt : Interrupt_ID) return Parameterless_Handler 312 is 313 begin 314 if Is_Reserved (Interrupt) then 315 raise Program_Error; 316 end if; 317 318 if Descriptors (Interrupt).Kind = Protected_Procedure then 319 return Descriptors (Interrupt).H; 320 else 321 return null; 322 end if; 323 end Current_Handler; 324 325 -------------------- 326 -- Attach_Handler -- 327 -------------------- 328 329 procedure Attach_Handler 330 (New_Handler : Parameterless_Handler; 331 Interrupt : Interrupt_ID; 332 Static : Boolean := False) 333 is 334 begin 335 Attach_Handler (New_Handler, Interrupt, Static, False); 336 end Attach_Handler; 337 338 procedure Attach_Handler 339 (New_Handler : Parameterless_Handler; 340 Interrupt : Interrupt_ID; 341 Static : Boolean; 342 Restoration : Boolean) 343 is 344 New_Task : Server_Task_Access; 345 346 begin 347 if Is_Reserved (Interrupt) then 348 raise Program_Error; 349 end if; 350 351 if not Restoration and then not Static 352 353 -- Tries to overwrite a static Interrupt Handler with dynamic handle 354 355 and then 356 (Descriptors (Interrupt).Static 357 358 -- New handler not specified as an Interrupt Handler by a pragma 359 360 or else not Is_Registered (New_Handler)) 361 then 362 raise Program_Error with 363 "trying to overwrite a static interrupt handler with a " & 364 "dynamic handler"; 365 end if; 366 367 if Handlers (Interrupt) = null then 368 New_Task := new Server_Task (Interrupt); 369 Handlers (Interrupt) := To_System (New_Task.all'Identity); 370 end if; 371 372 if intr_attach (int (Interrupt), 373 TISR (Signal_Handler'Access)) = FUNC_ERR 374 then 375 raise Program_Error; 376 end if; 377 378 if New_Handler = null then 379 380 -- The null handler means we are detaching the handler 381 382 Descriptors (Interrupt) := 383 (Kind => Unknown, T => null, E => 0, H => null, Static => False); 384 385 else 386 Descriptors (Interrupt).Kind := Protected_Procedure; 387 Descriptors (Interrupt).H := New_Handler; 388 Descriptors (Interrupt).Static := Static; 389 end if; 390 end Attach_Handler; 391 392 ---------------------- 393 -- Exchange_Handler -- 394 ---------------------- 395 396 procedure Exchange_Handler 397 (Old_Handler : out Parameterless_Handler; 398 New_Handler : Parameterless_Handler; 399 Interrupt : Interrupt_ID; 400 Static : Boolean := False) 401 is 402 begin 403 if Is_Reserved (Interrupt) then 404 raise Program_Error; 405 end if; 406 407 if Descriptors (Interrupt).Kind = Task_Entry then 408 409 -- In case we have an Interrupt Entry already installed, raise a 410 -- program error (propagate it to the caller). 411 412 raise Program_Error with "an interrupt is already installed"; 413 414 else 415 Old_Handler := Current_Handler (Interrupt); 416 Attach_Handler (New_Handler, Interrupt, Static); 417 end if; 418 end Exchange_Handler; 419 420 -------------------- 421 -- Detach_Handler -- 422 -------------------- 423 424 procedure Detach_Handler 425 (Interrupt : Interrupt_ID; 426 Static : Boolean := False) 427 is 428 begin 429 if Is_Reserved (Interrupt) then 430 raise Program_Error; 431 end if; 432 433 if Descriptors (Interrupt).Kind = Task_Entry then 434 raise Program_Error with "trying to detach an interrupt entry"; 435 end if; 436 437 if not Static and then Descriptors (Interrupt).Static then 438 raise Program_Error with 439 "trying to detach a static interrupt handler"; 440 end if; 441 442 Descriptors (Interrupt) := 443 (Kind => Unknown, T => null, E => 0, H => null, Static => False); 444 445 if intr_attach (int (Interrupt), null) = FUNC_ERR then 446 raise Program_Error; 447 end if; 448 end Detach_Handler; 449 450 --------------- 451 -- Reference -- 452 --------------- 453 454 function Reference (Interrupt : Interrupt_ID) return System.Address is 455 Signal : constant System.Address := 456 System.Storage_Elements.To_Address 457 (System.Storage_Elements.Integer_Address (Interrupt)); 458 459 begin 460 if Is_Reserved (Interrupt) then 461 462 -- Only usable Interrupts can be used for binding it to an Entry 463 464 raise Program_Error; 465 end if; 466 467 return Signal; 468 end Reference; 469 470 -------------------------------- 471 -- Register_Interrupt_Handler -- 472 -------------------------------- 473 474 procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is 475 begin 476 Registered_Handlers := 477 new Registered_Handler'(H => Handler_Addr, Next => Registered_Handlers); 478 end Register_Interrupt_Handler; 479 480 ------------------- 481 -- Is_Registered -- 482 ------------------- 483 484 -- See if the Handler has been "pragma"ed using Interrupt_Handler. 485 -- Always consider a null handler as registered. 486 487 function Is_Registered (Handler : Parameterless_Handler) return Boolean is 488 Ptr : R_Link := Registered_Handlers; 489 490 type Fat_Ptr is record 491 Object_Addr : System.Address; 492 Handler_Addr : System.Address; 493 end record; 494 495 function To_Fat_Ptr is new Ada.Unchecked_Conversion 496 (Parameterless_Handler, Fat_Ptr); 497 498 Fat : Fat_Ptr; 499 500 begin 501 if Handler = null then 502 return True; 503 end if; 504 505 Fat := To_Fat_Ptr (Handler); 506 507 while Ptr /= null loop 508 if Ptr.H = Fat.Handler_Addr then 509 return True; 510 end if; 511 512 Ptr := Ptr.Next; 513 end loop; 514 515 return False; 516 end Is_Registered; 517 518 ----------------------------- 519 -- Bind_Interrupt_To_Entry -- 520 ----------------------------- 521 522 procedure Bind_Interrupt_To_Entry 523 (T : Task_Id; 524 E : Task_Entry_Index; 525 Int_Ref : System.Address) 526 is 527 Interrupt : constant Interrupt_ID := 528 Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); 529 530 New_Task : Server_Task_Access; 531 532 begin 533 if Is_Reserved (Interrupt) then 534 raise Program_Error; 535 end if; 536 537 if Descriptors (Interrupt).Kind /= Unknown then 538 raise Program_Error with 539 "a binding for this interrupt is already present"; 540 end if; 541 542 if Handlers (Interrupt) = null then 543 New_Task := new Server_Task (Interrupt); 544 Handlers (Interrupt) := To_System (New_Task.all'Identity); 545 end if; 546 547 if intr_attach (int (Interrupt), 548 TISR (Signal_Handler'Access)) = FUNC_ERR 549 then 550 raise Program_Error; 551 end if; 552 553 Descriptors (Interrupt).Kind := Task_Entry; 554 Descriptors (Interrupt).T := T; 555 Descriptors (Interrupt).E := E; 556 557 -- Indicate the attachment of Interrupt Entry in ATCB. This is needed so 558 -- that when an Interrupt Entry task terminates the binding can be 559 -- cleaned up. The call to unbinding must be make by the task before it 560 -- terminates. 561 562 T.Interrupt_Entry := True; 563 end Bind_Interrupt_To_Entry; 564 565 ------------------------------ 566 -- Detach_Interrupt_Entries -- 567 ------------------------------ 568 569 procedure Detach_Interrupt_Entries (T : Task_Id) is 570 begin 571 for J in Interrupt_ID loop 572 if not Is_Reserved (J) then 573 if Descriptors (J).Kind = Task_Entry 574 and then Descriptors (J).T = T 575 then 576 Descriptors (J).Kind := Unknown; 577 578 if intr_attach (int (J), null) = FUNC_ERR then 579 raise Program_Error; 580 end if; 581 end if; 582 end if; 583 end loop; 584 585 -- Indicate in ATCB that no Interrupt Entries are attached 586 587 T.Interrupt_Entry := True; 588 end Detach_Interrupt_Entries; 589 590 --------------------- 591 -- Block_Interrupt -- 592 --------------------- 593 594 procedure Block_Interrupt (Interrupt : Interrupt_ID) is 595 begin 596 raise Program_Error; 597 end Block_Interrupt; 598 599 ----------------------- 600 -- Unblock_Interrupt -- 601 ----------------------- 602 603 procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is 604 begin 605 raise Program_Error; 606 end Unblock_Interrupt; 607 608 ---------------- 609 -- Is_Blocked -- 610 ---------------- 611 612 function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is 613 begin 614 raise Program_Error; 615 return False; 616 end Is_Blocked; 617 618 task body Server_Task is 619 Ignore : constant Boolean := Utilities.Make_Independent; 620 621 Desc : Handler_Desc renames Descriptors (Interrupt); 622 Self_Id : constant Task_Id := STPO.Self; 623 Temp : Parameterless_Handler; 624 625 begin 626 loop 627 while Interrupt_Count (Interrupt) > 0 loop 628 Interrupt_Count (Interrupt) := Interrupt_Count (Interrupt) - 1; 629 begin 630 case Desc.Kind is 631 when Unknown => 632 null; 633 when Task_Entry => 634 Rendezvous.Call_Simple (Desc.T, Desc.E, Null_Address); 635 when Protected_Procedure => 636 Temp := Desc.H; 637 Temp.all; 638 end case; 639 exception 640 when others => null; 641 end; 642 end loop; 643 644 Initialization.Defer_Abort (Self_Id); 645 646 if Single_Lock then 647 STPO.Lock_RTS; 648 end if; 649 650 STPO.Write_Lock (Self_Id); 651 Self_Id.Common.State := Interrupt_Server_Idle_Sleep; 652 STPO.Sleep (Self_Id, Interrupt_Server_Idle_Sleep); 653 Self_Id.Common.State := Runnable; 654 STPO.Unlock (Self_Id); 655 656 if Single_Lock then 657 STPO.Unlock_RTS; 658 end if; 659 660 Initialization.Undefer_Abort (Self_Id); 661 662 -- Undefer abort here to allow a window for this task to be aborted 663 -- at the time of system shutdown. 664 665 end loop; 666 end Server_Task; 667 668end System.Interrupts; 669