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-2012, 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 90 -- that 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 (Handlers : New_Handler_Array) is 296 begin 297 for N in Handlers'Range loop 298 Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True); 299 end loop; 300 end Install_Restricted_Handlers; 301 302 --------------------- 303 -- Current_Handler -- 304 --------------------- 305 306 function Current_Handler 307 (Interrupt : Interrupt_ID) return Parameterless_Handler 308 is 309 begin 310 if Is_Reserved (Interrupt) then 311 raise Program_Error; 312 end if; 313 314 if Descriptors (Interrupt).Kind = Protected_Procedure then 315 return Descriptors (Interrupt).H; 316 else 317 return null; 318 end if; 319 end Current_Handler; 320 321 -------------------- 322 -- Attach_Handler -- 323 -------------------- 324 325 procedure Attach_Handler 326 (New_Handler : Parameterless_Handler; 327 Interrupt : Interrupt_ID; 328 Static : Boolean := False) is 329 begin 330 Attach_Handler (New_Handler, Interrupt, Static, False); 331 end Attach_Handler; 332 333 procedure Attach_Handler 334 (New_Handler : Parameterless_Handler; 335 Interrupt : Interrupt_ID; 336 Static : Boolean; 337 Restoration : Boolean) 338 is 339 New_Task : Server_Task_Access; 340 341 begin 342 if Is_Reserved (Interrupt) then 343 raise Program_Error; 344 end if; 345 346 if not Restoration and then not Static 347 348 -- Tries to overwrite a static Interrupt Handler with dynamic handle 349 350 and then 351 (Descriptors (Interrupt).Static 352 353 -- New handler not specified as an Interrupt Handler by a pragma 354 355 or else not Is_Registered (New_Handler)) 356 then 357 raise Program_Error with 358 "Trying to overwrite a static Interrupt Handler with a " & 359 "dynamic Handler"; 360 end if; 361 362 if Handlers (Interrupt) = null then 363 New_Task := new Server_Task (Interrupt); 364 Handlers (Interrupt) := To_System (New_Task.all'Identity); 365 end if; 366 367 if intr_attach (int (Interrupt), 368 TISR (Signal_Handler'Access)) = FUNC_ERR 369 then 370 raise Program_Error; 371 end if; 372 373 if New_Handler = null then 374 375 -- The null handler means we are detaching the handler 376 377 Descriptors (Interrupt) := 378 (Kind => Unknown, T => null, E => 0, H => null, Static => False); 379 380 else 381 Descriptors (Interrupt).Kind := Protected_Procedure; 382 Descriptors (Interrupt).H := New_Handler; 383 Descriptors (Interrupt).Static := Static; 384 end if; 385 end Attach_Handler; 386 387 ---------------------- 388 -- Exchange_Handler -- 389 ---------------------- 390 391 procedure Exchange_Handler 392 (Old_Handler : out Parameterless_Handler; 393 New_Handler : Parameterless_Handler; 394 Interrupt : Interrupt_ID; 395 Static : Boolean := False) 396 is 397 begin 398 if Is_Reserved (Interrupt) then 399 raise Program_Error; 400 end if; 401 402 if Descriptors (Interrupt).Kind = Task_Entry then 403 404 -- In case we have an Interrupt Entry already installed. 405 -- raise a program error. (propagate it to the caller). 406 407 raise Program_Error with "An interrupt is already installed"; 408 409 else 410 Old_Handler := Current_Handler (Interrupt); 411 Attach_Handler (New_Handler, Interrupt, Static); 412 end if; 413 end Exchange_Handler; 414 415 -------------------- 416 -- Detach_Handler -- 417 -------------------- 418 419 procedure Detach_Handler 420 (Interrupt : Interrupt_ID; 421 Static : Boolean := False) 422 is 423 begin 424 if Is_Reserved (Interrupt) then 425 raise Program_Error; 426 end if; 427 428 if Descriptors (Interrupt).Kind = Task_Entry then 429 raise Program_Error with "Trying to detach an Interrupt Entry"; 430 end if; 431 432 if not Static and then Descriptors (Interrupt).Static then 433 raise Program_Error with 434 "Trying to detach a static Interrupt Handler"; 435 end if; 436 437 Descriptors (Interrupt) := 438 (Kind => Unknown, T => null, E => 0, H => null, Static => False); 439 440 if intr_attach (int (Interrupt), null) = FUNC_ERR then 441 raise Program_Error; 442 end if; 443 end Detach_Handler; 444 445 --------------- 446 -- Reference -- 447 --------------- 448 449 function Reference (Interrupt : Interrupt_ID) return System.Address is 450 Signal : constant System.Address := 451 System.Storage_Elements.To_Address 452 (System.Storage_Elements.Integer_Address (Interrupt)); 453 454 begin 455 if Is_Reserved (Interrupt) then 456 457 -- Only usable Interrupts can be used for binding it to an Entry 458 459 raise Program_Error; 460 end if; 461 462 return Signal; 463 end Reference; 464 465 -------------------------------- 466 -- Register_Interrupt_Handler -- 467 -------------------------------- 468 469 procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is 470 begin 471 Registered_Handlers := 472 new Registered_Handler'(H => Handler_Addr, Next => Registered_Handlers); 473 end Register_Interrupt_Handler; 474 475 ------------------- 476 -- Is_Registered -- 477 ------------------- 478 479 -- See if the Handler has been "pragma"ed using Interrupt_Handler. 480 -- Always consider a null handler as registered. 481 482 function Is_Registered (Handler : Parameterless_Handler) return Boolean is 483 Ptr : R_Link := Registered_Handlers; 484 485 type Fat_Ptr is record 486 Object_Addr : System.Address; 487 Handler_Addr : System.Address; 488 end record; 489 490 function To_Fat_Ptr is new Ada.Unchecked_Conversion 491 (Parameterless_Handler, Fat_Ptr); 492 493 Fat : Fat_Ptr; 494 495 begin 496 if Handler = null then 497 return True; 498 end if; 499 500 Fat := To_Fat_Ptr (Handler); 501 502 while Ptr /= null loop 503 504 if Ptr.H = Fat.Handler_Addr then 505 return True; 506 end if; 507 508 Ptr := Ptr.Next; 509 end loop; 510 511 return False; 512 end Is_Registered; 513 514 ----------------------------- 515 -- Bind_Interrupt_To_Entry -- 516 ----------------------------- 517 518 procedure Bind_Interrupt_To_Entry 519 (T : Task_Id; 520 E : Task_Entry_Index; 521 Int_Ref : System.Address) 522 is 523 Interrupt : constant Interrupt_ID := 524 Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); 525 526 New_Task : Server_Task_Access; 527 528 begin 529 if Is_Reserved (Interrupt) then 530 raise Program_Error; 531 end if; 532 533 if Descriptors (Interrupt).Kind /= Unknown then 534 raise Program_Error with 535 "A binding for this interrupt is already present"; 536 end if; 537 538 if Handlers (Interrupt) = null then 539 New_Task := new Server_Task (Interrupt); 540 Handlers (Interrupt) := To_System (New_Task.all'Identity); 541 end if; 542 543 if intr_attach (int (Interrupt), 544 TISR (Signal_Handler'Access)) = FUNC_ERR 545 then 546 raise Program_Error; 547 end if; 548 549 Descriptors (Interrupt).Kind := Task_Entry; 550 Descriptors (Interrupt).T := T; 551 Descriptors (Interrupt).E := E; 552 553 -- Indicate the attachment of Interrupt Entry in ATCB. This is needed so 554 -- that when an Interrupt Entry task terminates the binding can be 555 -- cleaned up. The call to unbinding must be make by the task before it 556 -- terminates. 557 558 T.Interrupt_Entry := True; 559 end Bind_Interrupt_To_Entry; 560 561 ------------------------------ 562 -- Detach_Interrupt_Entries -- 563 ------------------------------ 564 565 procedure Detach_Interrupt_Entries (T : Task_Id) is 566 begin 567 for J in Interrupt_ID loop 568 if not Is_Reserved (J) then 569 if Descriptors (J).Kind = Task_Entry 570 and then Descriptors (J).T = T 571 then 572 Descriptors (J).Kind := Unknown; 573 574 if intr_attach (int (J), null) = FUNC_ERR then 575 raise Program_Error; 576 end if; 577 end if; 578 end if; 579 end loop; 580 581 -- Indicate in ATCB that no Interrupt Entries are attached 582 583 T.Interrupt_Entry := True; 584 end Detach_Interrupt_Entries; 585 586 --------------------- 587 -- Block_Interrupt -- 588 --------------------- 589 590 procedure Block_Interrupt (Interrupt : Interrupt_ID) is 591 begin 592 raise Program_Error; 593 end Block_Interrupt; 594 595 ----------------------- 596 -- Unblock_Interrupt -- 597 ----------------------- 598 599 procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is 600 begin 601 raise Program_Error; 602 end Unblock_Interrupt; 603 604 ---------------- 605 -- Is_Blocked -- 606 ---------------- 607 608 function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is 609 begin 610 raise Program_Error; 611 return False; 612 end Is_Blocked; 613 614 task body Server_Task is 615 Desc : Handler_Desc renames Descriptors (Interrupt); 616 Self_Id : constant Task_Id := STPO.Self; 617 Temp : Parameterless_Handler; 618 619 begin 620 Utilities.Make_Independent; 621 622 loop 623 while Interrupt_Count (Interrupt) > 0 loop 624 Interrupt_Count (Interrupt) := Interrupt_Count (Interrupt) - 1; 625 begin 626 case Desc.Kind is 627 when Unknown => 628 null; 629 when Task_Entry => 630 Rendezvous.Call_Simple (Desc.T, Desc.E, Null_Address); 631 when Protected_Procedure => 632 Temp := Desc.H; 633 Temp.all; 634 end case; 635 exception 636 when others => null; 637 end; 638 end loop; 639 640 Initialization.Defer_Abort (Self_Id); 641 642 if Single_Lock then 643 STPO.Lock_RTS; 644 end if; 645 646 STPO.Write_Lock (Self_Id); 647 Self_Id.Common.State := Interrupt_Server_Idle_Sleep; 648 STPO.Sleep (Self_Id, Interrupt_Server_Idle_Sleep); 649 Self_Id.Common.State := Runnable; 650 STPO.Unlock (Self_Id); 651 652 if Single_Lock then 653 STPO.Unlock_RTS; 654 end if; 655 656 Initialization.Undefer_Abort (Self_Id); 657 658 -- Undefer abort here to allow a window for this task to be aborted 659 -- at the time of system shutdown. 660 661 end loop; 662 end Server_Task; 663 664end System.Interrupts; 665