1------------------------------------------------------------------------------ 2-- -- 3-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- 4-- -- 5-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2003, 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, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, 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-- This is a Solaris (native) version of this package 35 36-- This package contains all the GNULL primitives that interface directly 37-- with the underlying OS. 38 39pragma Polling (Off); 40-- Turn off polling, we do not want ATC polling to take place during 41-- tasking operations. It causes infinite loops and other problems. 42 43with System.Tasking.Debug; 44-- used for Known_Tasks 45 46with Ada.Exceptions; 47-- used for Raise_Exception 48 49with GNAT.OS_Lib; 50-- used for String_Access, Getenv 51 52with Interfaces.C; 53-- used for int 54-- size_t 55 56with System.Interrupt_Management; 57-- used for Keep_Unmasked 58-- Abort_Task_Interrupt 59-- Interrupt_ID 60 61with System.Interrupt_Management.Operations; 62-- used for Set_Interrupt_Mask 63-- All_Tasks_Mask 64pragma Elaborate_All (System.Interrupt_Management.Operations); 65 66with System.Parameters; 67-- used for Size_Type 68 69with System.Tasking; 70-- used for Ada_Task_Control_Block 71-- Task_ID 72-- ATCB components and types 73 74with System.Task_Info; 75-- to initialize Task_Info for a C thread, in function Self 76 77with System.Soft_Links; 78-- used for Defer/Undefer_Abort 79-- to initialize TSD for a C thread, in function Self 80 81-- Note that we do not use System.Tasking.Initialization directly since 82-- this is a higher level package that we shouldn't depend on. For example 83-- when using the restricted run time, it is replaced by 84-- System.Tasking.Restricted.Initialization 85 86with System.OS_Primitives; 87-- used for Delay_Modes 88 89with Unchecked_Conversion; 90with Unchecked_Deallocation; 91 92package body System.Task_Primitives.Operations is 93 94 use System.Tasking.Debug; 95 use System.Tasking; 96 use Interfaces.C; 97 use System.OS_Interface; 98 use System.Parameters; 99 use Ada.Exceptions; 100 use System.OS_Primitives; 101 102 package SSL renames System.Soft_Links; 103 104 ---------------- 105 -- Local Data -- 106 ---------------- 107 108 -- The following are logically constants, but need to be initialized 109 -- at run time. 110 111 Environment_Task_ID : Task_ID; 112 -- A variable to hold Task_ID for the environment task. 113 -- If we use this variable to get the Task_ID, we need the following 114 -- ATCB_Key only for non-Ada threads. 115 116 Unblocked_Signal_Mask : aliased sigset_t; 117 -- The set of signals that should unblocked in all tasks 118 119 ATCB_Key : aliased thread_key_t; 120 -- Key used to find the Ada Task_ID associated with a thread, 121 -- at least for C threads unknown to the Ada run-time system. 122 123 Single_RTS_Lock : aliased RTS_Lock; 124 -- This is a lock to allow only one thread of control in the RTS at 125 -- a time; it is used to execute in mutual exclusion from all other tasks. 126 -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List 127 128 Next_Serial_Number : Task_Serial_Number := 100; 129 -- We start at 100, to reserve some special values for 130 -- using in error checking. 131 -- The following are internal configuration constants needed. 132 133 ---------------------- 134 -- Priority Support -- 135 ---------------------- 136 137 Priority_Ceiling_Emulation : constant Boolean := True; 138 -- controls whether we emulate priority ceiling locking 139 140 -- To get a scheduling close to annex D requirements, we use the real-time 141 -- class provided for LWP's and map each task/thread to a specific and 142 -- unique LWP (there is 1 thread per LWP, and 1 LWP per thread). 143 144 -- The real time class can only be set when the process has root 145 -- priviledges, so in the other cases, we use the normal thread scheduling 146 -- and priority handling. 147 148 Using_Real_Time_Class : Boolean := False; 149 -- indicates wether the real time class is being used (i.e the process 150 -- has root priviledges). 151 152 Prio_Param : aliased struct_pcparms; 153 -- Hold priority info (Real_Time) initialized during the package 154 -- elaboration. 155 156 ----------------------------------- 157 -- External Configuration Values -- 158 ----------------------------------- 159 160 Time_Slice_Val : Interfaces.C.long; 161 pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); 162 163 Locking_Policy : Character; 164 pragma Import (C, Locking_Policy, "__gl_locking_policy"); 165 166 Dispatching_Policy : Character; 167 pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); 168 169 Foreign_Task_Elaborated : aliased Boolean := True; 170 -- Used to identified fake tasks (i.e., non-Ada Threads). 171 172 ----------------------- 173 -- Local Subprograms -- 174 ----------------------- 175 176 function sysconf (name : System.OS_Interface.int) 177 return processorid_t; 178 pragma Import (C, sysconf, "sysconf"); 179 180 SC_NPROCESSORS_CONF : constant System.OS_Interface.int := 14; 181 182 function Num_Procs (name : System.OS_Interface.int := SC_NPROCESSORS_CONF) 183 return processorid_t renames sysconf; 184 185 procedure Abort_Handler 186 (Sig : Signal; 187 Code : access siginfo_t; 188 Context : access ucontext_t); 189 -- Target-dependent binding of inter-thread Abort signal to 190 -- the raising of the Abort_Signal exception. 191 -- See also comments in 7staprop.adb 192 193 function To_thread_t is new Unchecked_Conversion 194 (Integer, System.OS_Interface.thread_t); 195 196 function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID); 197 198 function To_Address is new Unchecked_Conversion (Task_ID, System.Address); 199 200 function Thread_Body_Access is 201 new Unchecked_Conversion (System.Address, Thread_Body); 202 203 ------------ 204 -- Checks -- 205 ------------ 206 207 function Check_Initialize_Lock (L : Lock_Ptr; Level : Lock_Level) 208 return Boolean; 209 pragma Inline (Check_Initialize_Lock); 210 211 function Check_Lock (L : Lock_Ptr) return Boolean; 212 pragma Inline (Check_Lock); 213 214 function Record_Lock (L : Lock_Ptr) return Boolean; 215 pragma Inline (Record_Lock); 216 217 function Check_Sleep (Reason : Task_States) return Boolean; 218 pragma Inline (Check_Sleep); 219 220 function Record_Wakeup 221 (L : Lock_Ptr; 222 Reason : Task_States) return Boolean; 223 pragma Inline (Record_Wakeup); 224 225 function Check_Wakeup 226 (T : Task_ID; 227 Reason : Task_States) return Boolean; 228 pragma Inline (Check_Wakeup); 229 230 function Check_Unlock (L : Lock_Ptr) return Boolean; 231 pragma Inline (Check_Lock); 232 233 function Check_Finalize_Lock (L : Lock_Ptr) return Boolean; 234 pragma Inline (Check_Finalize_Lock); 235 236 -------------------- 237 -- Local Packages -- 238 -------------------- 239 240 package Specific is 241 242 procedure Initialize (Environment_Task : Task_ID); 243 pragma Inline (Initialize); 244 -- Initialize various data needed by this package. 245 246 function Is_Valid_Task return Boolean; 247 pragma Inline (Is_Valid_Task); 248 -- Does executing thread have a TCB? 249 250 procedure Set (Self_Id : Task_ID); 251 pragma Inline (Set); 252 -- Set the self id for the current task. 253 254 function Self return Task_ID; 255 pragma Inline (Self); 256 -- Return a pointer to the Ada Task Control Block of the calling task. 257 258 end Specific; 259 260 package body Specific is separate; 261 -- The body of this package is target specific. 262 263 --------------------------------- 264 -- Support for foreign threads -- 265 --------------------------------- 266 267 function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; 268 -- Allocate and Initialize a new ATCB for the current Thread. 269 270 function Register_Foreign_Thread 271 (Thread : Thread_Id) return Task_ID is separate; 272 273 ------------ 274 -- Checks -- 275 ------------ 276 277 Check_Count : Integer := 0; 278 Lock_Count : Integer := 0; 279 Unlock_Count : Integer := 0; 280 281 function To_Lock_Ptr is 282 new Unchecked_Conversion (RTS_Lock_Ptr, Lock_Ptr); 283 function To_Owner_ID is 284 new Unchecked_Conversion (Task_ID, Owner_ID); 285 286 ------------------- 287 -- Abort_Handler -- 288 ------------------- 289 290 procedure Abort_Handler 291 (Sig : Signal; 292 Code : access siginfo_t; 293 Context : access ucontext_t) 294 is 295 pragma Unreferenced (Sig); 296 pragma Unreferenced (Code); 297 pragma Unreferenced (Context); 298 299 Self_ID : Task_ID := Self; 300 Old_Set : aliased sigset_t; 301 302 Result : Interfaces.C.int; 303 pragma Unreferenced (Result); 304 305 begin 306 -- It is not safe to raise an exception when using ZCX and the GCC 307 -- exception handling mechanism. 308 309 if ZCX_By_Default and then GCC_ZCX_Support then 310 return; 311 end if; 312 313 if Self_ID.Deferral_Level = 0 314 and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level 315 and then not Self_ID.Aborting 316 then 317 Self_ID.Aborting := True; 318 319 -- Make sure signals used for RTS internal purpose are unmasked 320 321 Result := thr_sigsetmask (SIG_UNBLOCK, 322 Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access); 323 pragma Assert (Result = 0); 324 325 raise Standard'Abort_Signal; 326 end if; 327 end Abort_Handler; 328 329 ------------------- 330 -- Stack_Guard -- 331 ------------------- 332 333 -- The underlying thread system sets a guard page at the 334 -- bottom of a thread stack, so nothing is needed. 335 336 procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is 337 pragma Unreferenced (T); 338 pragma Unreferenced (On); 339 340 begin 341 null; 342 end Stack_Guard; 343 344 -------------------- 345 -- Get_Thread_Id -- 346 -------------------- 347 348 function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is 349 begin 350 return T.Common.LL.Thread; 351 end Get_Thread_Id; 352 353 ---------------- 354 -- Initialize -- 355 ---------------- 356 357 procedure Initialize (Environment_Task : ST.Task_ID) is 358 act : aliased struct_sigaction; 359 old_act : aliased struct_sigaction; 360 Tmp_Set : aliased sigset_t; 361 Result : Interfaces.C.int; 362 363 procedure Configure_Processors; 364 -- Processors configuration 365 -- The user can specify a processor which the program should run 366 -- on to emulate a single-processor system. This can be easily 367 -- done by setting environment variable GNAT_PROCESSOR to one of 368 -- the following : 369 -- 370 -- -2 : use the default configuration (run the program on all 371 -- available processors) - this is the same as having 372 -- GNAT_PROCESSOR unset 373 -- -1 : let the RTS choose one processor and run the program on 374 -- that processor 375 -- 0 .. Last_Proc : run the program on the specified processor 376 -- 377 -- Last_Proc is equal to the value of the system variable 378 -- _SC_NPROCESSORS_CONF, minus one. 379 380 procedure Configure_Processors is 381 Proc_Acc : constant GNAT.OS_Lib.String_Access := 382 GNAT.OS_Lib.Getenv ("GNAT_PROCESSOR"); 383 Proc : aliased processorid_t; -- User processor # 384 Last_Proc : processorid_t; -- Last processor # 385 386 begin 387 if Proc_Acc.all'Length /= 0 then 388 -- Environment variable is defined 389 390 Last_Proc := Num_Procs - 1; 391 392 if Last_Proc /= -1 then 393 Proc := processorid_t'Value (Proc_Acc.all); 394 395 if Proc <= -2 or else Proc > Last_Proc then 396 -- Use the default configuration 397 null; 398 elsif Proc = -1 then 399 -- Choose a processor 400 401 Result := 0; 402 403 while Proc < Last_Proc loop 404 Proc := Proc + 1; 405 Result := p_online (Proc, PR_STATUS); 406 exit when Result = PR_ONLINE; 407 end loop; 408 409 pragma Assert (Result = PR_ONLINE); 410 Result := processor_bind (P_PID, P_MYID, Proc, null); 411 pragma Assert (Result = 0); 412 413 else 414 -- Use user processor 415 416 Result := processor_bind (P_PID, P_MYID, Proc, null); 417 pragma Assert (Result = 0); 418 end if; 419 end if; 420 end if; 421 422 exception 423 when Constraint_Error => 424 425 -- Illegal environment variable GNAT_PROCESSOR - ignored 426 427 null; 428 end Configure_Processors; 429 430 function State (Int : System.Interrupt_Management.Interrupt_ID) 431 return Character; 432 pragma Import (C, State, "__gnat_get_interrupt_state"); 433 -- Get interrupt state. Defined in a-init.c 434 -- The input argument is the interrupt number, 435 -- and the result is one of the following: 436 437 Default : constant Character := 's'; 438 -- 'n' this interrupt not set by any Interrupt_State pragma 439 -- 'u' Interrupt_State pragma set state to User 440 -- 'r' Interrupt_State pragma set state to Runtime 441 -- 's' Interrupt_State pragma set state to System (use "default" 442 -- system handler) 443 444 -- Start of processing for Initialize 445 446 begin 447 Environment_Task_ID := Environment_Task; 448 449 -- This is done in Enter_Task, but this is too late for the 450 -- Environment Task, since we need to call Self in Check_Locks when 451 -- the run time is compiled with assertions on. 452 453 Specific.Initialize (Environment_Task); 454 455 -- Initialize the lock used to synchronize chain of all ATCBs. 456 457 Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); 458 459 Enter_Task (Environment_Task); 460 461 -- Install the abort-signal handler 462 463 if State (System.Interrupt_Management.Abort_Task_Interrupt) 464 /= Default 465 then 466 -- Set sa_flags to SA_NODEFER so that during the handler execution 467 -- we do not change the Signal_Mask to be masked for the Abort_Signal 468 -- This is a temporary fix to the problem that the Signal_Mask is 469 -- not restored after the exception (longjmp) from the handler. 470 -- The right fix should be made in sigsetjmp so that we save 471 -- the Signal_Set and restore it after a longjmp. 472 -- In that case, this field should be changed back to 0. ??? 473 474 act.sa_flags := 16; 475 476 act.sa_handler := Abort_Handler'Address; 477 Result := sigemptyset (Tmp_Set'Access); 478 pragma Assert (Result = 0); 479 act.sa_mask := Tmp_Set; 480 481 Result := 482 sigaction ( 483 Signal (System.Interrupt_Management.Abort_Task_Interrupt), 484 act'Unchecked_Access, 485 old_act'Unchecked_Access); 486 pragma Assert (Result = 0); 487 end if; 488 489 Configure_Processors; 490 end Initialize; 491 492 --------------------- 493 -- Initialize_Lock -- 494 --------------------- 495 496 -- Note: mutexes and cond_variables needed per-task basis are 497 -- initialized in Initialize_TCB and the Storage_Error is 498 -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) 499 -- used in RTS is initialized before any status change of RTS. 500 -- Therefore rasing Storage_Error in the following routines 501 -- should be able to be handled safely. 502 503 procedure Initialize_Lock 504 (Prio : System.Any_Priority; 505 L : access Lock) 506 is 507 Result : Interfaces.C.int; 508 509 begin 510 pragma Assert (Check_Initialize_Lock (Lock_Ptr (L), PO_Level)); 511 512 if Priority_Ceiling_Emulation then 513 L.Ceiling := Prio; 514 end if; 515 516 Result := mutex_init (L.L'Access, USYNC_THREAD, System.Null_Address); 517 pragma Assert (Result = 0 or else Result = ENOMEM); 518 519 if Result = ENOMEM then 520 Raise_Exception (Storage_Error'Identity, "Failed to allocate a lock"); 521 end if; 522 end Initialize_Lock; 523 524 procedure Initialize_Lock 525 (L : access RTS_Lock; 526 Level : Lock_Level) 527 is 528 Result : Interfaces.C.int; 529 530 begin 531 pragma Assert (Check_Initialize_Lock 532 (To_Lock_Ptr (RTS_Lock_Ptr (L)), Level)); 533 Result := mutex_init (L.L'Access, USYNC_THREAD, System.Null_Address); 534 pragma Assert (Result = 0 or else Result = ENOMEM); 535 536 if Result = ENOMEM then 537 Raise_Exception (Storage_Error'Identity, "Failed to allocate a lock"); 538 end if; 539 end Initialize_Lock; 540 541 ------------------- 542 -- Finalize_Lock -- 543 ------------------- 544 545 procedure Finalize_Lock (L : access Lock) is 546 Result : Interfaces.C.int; 547 548 begin 549 pragma Assert (Check_Finalize_Lock (Lock_Ptr (L))); 550 Result := mutex_destroy (L.L'Access); 551 pragma Assert (Result = 0); 552 end Finalize_Lock; 553 554 procedure Finalize_Lock (L : access RTS_Lock) is 555 Result : Interfaces.C.int; 556 557 begin 558 pragma Assert (Check_Finalize_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); 559 Result := mutex_destroy (L.L'Access); 560 pragma Assert (Result = 0); 561 end Finalize_Lock; 562 563 ---------------- 564 -- Write_Lock -- 565 ---------------- 566 567 procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is 568 Result : Interfaces.C.int; 569 570 begin 571 pragma Assert (Check_Lock (Lock_Ptr (L))); 572 573 if Priority_Ceiling_Emulation and then Locking_Policy = 'C' then 574 declare 575 Self_Id : constant Task_ID := Self; 576 Saved_Priority : System.Any_Priority; 577 578 begin 579 if Self_Id.Common.LL.Active_Priority > L.Ceiling then 580 Ceiling_Violation := True; 581 return; 582 end if; 583 584 Saved_Priority := Self_Id.Common.LL.Active_Priority; 585 586 if Self_Id.Common.LL.Active_Priority < L.Ceiling then 587 Set_Priority (Self_Id, L.Ceiling); 588 end if; 589 590 Result := mutex_lock (L.L'Access); 591 pragma Assert (Result = 0); 592 Ceiling_Violation := False; 593 594 L.Saved_Priority := Saved_Priority; 595 end; 596 597 else 598 Result := mutex_lock (L.L'Access); 599 pragma Assert (Result = 0); 600 Ceiling_Violation := False; 601 end if; 602 603 pragma Assert (Record_Lock (Lock_Ptr (L))); 604 end Write_Lock; 605 606 procedure Write_Lock 607 (L : access RTS_Lock; 608 Global_Lock : Boolean := False) 609 is 610 Result : Interfaces.C.int; 611 612 begin 613 if not Single_Lock or else Global_Lock then 614 pragma Assert (Check_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); 615 Result := mutex_lock (L.L'Access); 616 pragma Assert (Result = 0); 617 pragma Assert (Record_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); 618 end if; 619 end Write_Lock; 620 621 procedure Write_Lock (T : Task_ID) is 622 Result : Interfaces.C.int; 623 624 begin 625 if not Single_Lock then 626 pragma Assert (Check_Lock (To_Lock_Ptr (T.Common.LL.L'Access))); 627 Result := mutex_lock (T.Common.LL.L.L'Access); 628 pragma Assert (Result = 0); 629 pragma Assert (Record_Lock (To_Lock_Ptr (T.Common.LL.L'Access))); 630 end if; 631 end Write_Lock; 632 633 --------------- 634 -- Read_Lock -- 635 --------------- 636 637 procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is 638 begin 639 Write_Lock (L, Ceiling_Violation); 640 end Read_Lock; 641 642 ------------ 643 -- Unlock -- 644 ------------ 645 646 procedure Unlock (L : access Lock) is 647 Result : Interfaces.C.int; 648 649 begin 650 pragma Assert (Check_Unlock (Lock_Ptr (L))); 651 652 if Priority_Ceiling_Emulation and then Locking_Policy = 'C' then 653 declare 654 Self_Id : constant Task_ID := Self; 655 656 begin 657 Result := mutex_unlock (L.L'Access); 658 pragma Assert (Result = 0); 659 660 if Self_Id.Common.LL.Active_Priority > L.Saved_Priority then 661 Set_Priority (Self_Id, L.Saved_Priority); 662 end if; 663 end; 664 else 665 Result := mutex_unlock (L.L'Access); 666 pragma Assert (Result = 0); 667 end if; 668 end Unlock; 669 670 procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is 671 Result : Interfaces.C.int; 672 673 begin 674 if not Single_Lock or else Global_Lock then 675 pragma Assert (Check_Unlock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); 676 Result := mutex_unlock (L.L'Access); 677 pragma Assert (Result = 0); 678 end if; 679 end Unlock; 680 681 procedure Unlock (T : Task_ID) is 682 Result : Interfaces.C.int; 683 684 begin 685 if not Single_Lock then 686 pragma Assert (Check_Unlock (To_Lock_Ptr (T.Common.LL.L'Access))); 687 Result := mutex_unlock (T.Common.LL.L.L'Access); 688 pragma Assert (Result = 0); 689 end if; 690 end Unlock; 691 692 -- For the time delay implementation, we need to make sure we 693 -- achieve following criteria: 694 695 -- 1) We have to delay at least for the amount requested. 696 -- 2) We have to give up CPU even though the actual delay does not 697 -- result in blocking. 698 -- 3) Except for restricted run-time systems that do not support 699 -- ATC or task abort, the delay must be interrupted by the 700 -- abort_task operation. 701 -- 4) The implementation has to be efficient so that the delay overhead 702 -- is relatively cheap. 703 -- (1)-(3) are Ada requirements. Even though (2) is an Annex-D 704 -- requirement we still want to provide the effect in all cases. 705 -- The reason is that users may want to use short delays to implement 706 -- their own scheduling effect in the absence of language provided 707 -- scheduling policies. 708 709 --------------------- 710 -- Monotonic_Clock -- 711 --------------------- 712 713 function Monotonic_Clock return Duration is 714 TS : aliased timespec; 715 Result : Interfaces.C.int; 716 717 begin 718 Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); 719 pragma Assert (Result = 0); 720 return To_Duration (TS); 721 end Monotonic_Clock; 722 723 ------------------- 724 -- RT_Resolution -- 725 ------------------- 726 727 function RT_Resolution return Duration is 728 begin 729 return 10#1.0#E-6; 730 end RT_Resolution; 731 732 ----------- 733 -- Yield -- 734 ----------- 735 736 procedure Yield (Do_Yield : Boolean := True) is 737 begin 738 if Do_Yield then 739 System.OS_Interface.thr_yield; 740 end if; 741 end Yield; 742 743 ----------- 744 -- Self --- 745 ----------- 746 747 function Self return Task_ID renames Specific.Self; 748 749 ------------------ 750 -- Set_Priority -- 751 ------------------ 752 753 procedure Set_Priority 754 (T : Task_ID; 755 Prio : System.Any_Priority; 756 Loss_Of_Inheritance : Boolean := False) 757 is 758 pragma Unreferenced (Loss_Of_Inheritance); 759 760 Result : Interfaces.C.int; 761 pragma Unreferenced (Result); 762 763 Param : aliased struct_pcparms; 764 765 use Task_Info; 766 767 begin 768 T.Common.Current_Priority := Prio; 769 770 if Priority_Ceiling_Emulation then 771 T.Common.LL.Active_Priority := Prio; 772 end if; 773 774 if Using_Real_Time_Class then 775 Param.pc_cid := Prio_Param.pc_cid; 776 Param.rt_pri := pri_t (Prio); 777 Param.rt_tqsecs := Prio_Param.rt_tqsecs; 778 Param.rt_tqnsecs := Prio_Param.rt_tqnsecs; 779 780 Result := Interfaces.C.int ( 781 priocntl (PC_VERSION, P_LWPID, T.Common.LL.LWP, PC_SETPARMS, 782 Param'Address)); 783 784 else 785 if T.Common.Task_Info /= null 786 and then not T.Common.Task_Info.Bound_To_LWP 787 then 788 -- The task is not bound to a LWP, so use thr_setprio 789 790 Result := 791 thr_setprio (T.Common.LL.Thread, Interfaces.C.int (Prio)); 792 793 else 794 795 -- The task is bound to a LWP, use priocntl 796 -- ??? TBD 797 798 null; 799 end if; 800 end if; 801 end Set_Priority; 802 803 ------------------ 804 -- Get_Priority -- 805 ------------------ 806 807 function Get_Priority (T : Task_ID) return System.Any_Priority is 808 begin 809 return T.Common.Current_Priority; 810 end Get_Priority; 811 812 ---------------- 813 -- Enter_Task -- 814 ---------------- 815 816 procedure Enter_Task (Self_ID : Task_ID) is 817 Result : Interfaces.C.int; 818 Proc : processorid_t; -- User processor # 819 Last_Proc : processorid_t; -- Last processor # 820 821 use System.Task_Info; 822 begin 823 Self_ID.Common.LL.Thread := thr_self; 824 825 Self_ID.Common.LL.LWP := lwp_self; 826 827 if Self_ID.Common.Task_Info /= null then 828 if Self_ID.Common.Task_Info.New_LWP 829 and then Self_ID.Common.Task_Info.CPU /= CPU_UNCHANGED 830 then 831 Last_Proc := Num_Procs - 1; 832 833 if Self_ID.Common.Task_Info.CPU = ANY_CPU then 834 Result := 0; 835 Proc := 0; 836 837 while Proc < Last_Proc loop 838 Result := p_online (Proc, PR_STATUS); 839 exit when Result = PR_ONLINE; 840 Proc := Proc + 1; 841 end loop; 842 843 Result := processor_bind (P_LWPID, P_MYID, Proc, null); 844 pragma Assert (Result = 0); 845 846 else 847 -- Use specified processor 848 849 if Self_ID.Common.Task_Info.CPU < 0 850 or else Self_ID.Common.Task_Info.CPU > Last_Proc 851 then 852 raise Invalid_CPU_Number; 853 end if; 854 855 Result := processor_bind 856 (P_LWPID, P_MYID, Self_ID.Common.Task_Info.CPU, null); 857 pragma Assert (Result = 0); 858 end if; 859 end if; 860 end if; 861 862 Specific.Set (Self_ID); 863 864 -- We need the above code even if we do direct fetch of Task_ID in Self 865 -- for the main task on Sun, x86 Solaris and for gcc 2.7.2. 866 867 Lock_RTS; 868 869 for J in Known_Tasks'Range loop 870 if Known_Tasks (J) = null then 871 Known_Tasks (J) := Self_ID; 872 Self_ID.Known_Tasks_Index := J; 873 exit; 874 end if; 875 end loop; 876 877 Unlock_RTS; 878 end Enter_Task; 879 880 -------------- 881 -- New_ATCB -- 882 -------------- 883 884 function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is 885 begin 886 return new Ada_Task_Control_Block (Entry_Num); 887 end New_ATCB; 888 889 ------------------- 890 -- Is_Valid_Task -- 891 ------------------- 892 893 function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; 894 895 ----------------------------- 896 -- Register_Foreign_Thread -- 897 ----------------------------- 898 899 function Register_Foreign_Thread return Task_ID is 900 901 begin 902 if Is_Valid_Task then 903 return Self; 904 else 905 return Register_Foreign_Thread (thr_self); 906 end if; 907 end Register_Foreign_Thread; 908 909 -------------------- 910 -- Initialize_TCB -- 911 -------------------- 912 913 procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is 914 Result : Interfaces.C.int := 0; 915 916 begin 917 -- Give the task a unique serial number. 918 919 Self_ID.Serial_Number := Next_Serial_Number; 920 Next_Serial_Number := Next_Serial_Number + 1; 921 pragma Assert (Next_Serial_Number /= 0); 922 923 Self_ID.Common.LL.Thread := To_thread_t (-1); 924 925 if not Single_Lock then 926 Result := mutex_init 927 (Self_ID.Common.LL.L.L'Access, USYNC_THREAD, System.Null_Address); 928 Self_ID.Common.LL.L.Level := 929 Private_Task_Serial_Number (Self_ID.Serial_Number); 930 pragma Assert (Result = 0 or else Result = ENOMEM); 931 end if; 932 933 if Result = 0 then 934 Result := cond_init (Self_ID.Common.LL.CV'Access, USYNC_THREAD, 0); 935 pragma Assert (Result = 0 or else Result = ENOMEM); 936 end if; 937 938 if Result = 0 then 939 Succeeded := True; 940 else 941 if not Single_Lock then 942 Result := mutex_destroy (Self_ID.Common.LL.L.L'Access); 943 pragma Assert (Result = 0); 944 end if; 945 946 Succeeded := False; 947 end if; 948 end Initialize_TCB; 949 950 ----------------- 951 -- Create_Task -- 952 ----------------- 953 954 procedure Create_Task 955 (T : Task_ID; 956 Wrapper : System.Address; 957 Stack_Size : System.Parameters.Size_Type; 958 Priority : System.Any_Priority; 959 Succeeded : out Boolean) 960 is 961 pragma Unreferenced (Priority); 962 963 Result : Interfaces.C.int; 964 Adjusted_Stack_Size : Interfaces.C.size_t; 965 Opts : Interfaces.C.int := THR_DETACHED; 966 967 Page_Size : constant System.Parameters.Size_Type := 4096; 968 -- This constant is for reserving extra space at the 969 -- end of the stack, which can be used by the stack 970 -- checking as guard page. The idea is that we need 971 -- to have at least Stack_Size bytes available for 972 -- actual use. 973 974 use System.Task_Info; 975 976 begin 977 if Stack_Size = System.Parameters.Unspecified_Size then 978 Adjusted_Stack_Size := 979 Interfaces.C.size_t (Default_Stack_Size + Page_Size); 980 981 elsif Stack_Size < Minimum_Stack_Size then 982 Adjusted_Stack_Size := 983 Interfaces.C.size_t (Minimum_Stack_Size + Page_Size); 984 985 else 986 Adjusted_Stack_Size := 987 Interfaces.C.size_t (Stack_Size + Page_Size); 988 end if; 989 990 -- Since the initial signal mask of a thread is inherited from the 991 -- creator, and the Environment task has all its signals masked, we 992 -- do not need to manipulate caller's signal mask at this point. 993 -- All tasks in RTS will have All_Tasks_Mask initially. 994 995 if T.Common.Task_Info /= null then 996 if T.Common.Task_Info.New_LWP then 997 Opts := Opts + THR_NEW_LWP; 998 end if; 999 1000 if T.Common.Task_Info.Bound_To_LWP then 1001 Opts := Opts + THR_BOUND; 1002 end if; 1003 1004 else 1005 Opts := THR_DETACHED + THR_BOUND; 1006 end if; 1007 1008 Result := thr_create 1009 (System.Null_Address, 1010 Adjusted_Stack_Size, 1011 Thread_Body_Access (Wrapper), 1012 To_Address (T), 1013 Opts, 1014 T.Common.LL.Thread'Access); 1015 1016 Succeeded := Result = 0; 1017 pragma Assert 1018 (Result = 0 1019 or else Result = ENOMEM 1020 or else Result = EAGAIN); 1021 end Create_Task; 1022 1023 ------------------ 1024 -- Finalize_TCB -- 1025 ------------------ 1026 1027 procedure Finalize_TCB (T : Task_ID) is 1028 Result : Interfaces.C.int; 1029 Tmp : Task_ID := T; 1030 Is_Self : constant Boolean := T = Self; 1031 1032 procedure Free is new 1033 Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); 1034 1035 begin 1036 T.Common.LL.Thread := To_thread_t (0); 1037 1038 if not Single_Lock then 1039 Result := mutex_destroy (T.Common.LL.L.L'Access); 1040 pragma Assert (Result = 0); 1041 end if; 1042 1043 Result := cond_destroy (T.Common.LL.CV'Access); 1044 pragma Assert (Result = 0); 1045 1046 if T.Known_Tasks_Index /= -1 then 1047 Known_Tasks (T.Known_Tasks_Index) := null; 1048 end if; 1049 1050 Free (Tmp); 1051 1052 if Is_Self then 1053 Specific.Set (null); 1054 end if; 1055 1056 end Finalize_TCB; 1057 1058 --------------- 1059 -- Exit_Task -- 1060 --------------- 1061 1062 -- This procedure must be called with abort deferred. 1063 -- It can no longer call Self or access 1064 -- the current task's ATCB, since the ATCB has been deallocated. 1065 1066 procedure Exit_Task is 1067 begin 1068 Specific.Set (null); 1069 end Exit_Task; 1070 1071 ---------------- 1072 -- Abort_Task -- 1073 ---------------- 1074 1075 procedure Abort_Task (T : Task_ID) is 1076 Result : Interfaces.C.int; 1077 begin 1078 pragma Assert (T /= Self); 1079 1080 Result := thr_kill (T.Common.LL.Thread, 1081 Signal (System.Interrupt_Management.Abort_Task_Interrupt)); 1082 null; 1083 1084 pragma Assert (Result = 0); 1085 end Abort_Task; 1086 1087 ----------- 1088 -- Sleep -- 1089 ----------- 1090 1091 procedure Sleep 1092 (Self_ID : Task_ID; 1093 Reason : Task_States) 1094 is 1095 Result : Interfaces.C.int; 1096 1097 begin 1098 pragma Assert (Check_Sleep (Reason)); 1099 1100 if Dynamic_Priority_Support 1101 and then Self_ID.Pending_Priority_Change 1102 then 1103 Self_ID.Pending_Priority_Change := False; 1104 Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; 1105 Set_Priority (Self_ID, Self_ID.Common.Base_Priority); 1106 end if; 1107 1108 if Single_Lock then 1109 Result := cond_wait 1110 (Self_ID.Common.LL.CV'Access, Single_RTS_Lock.L'Access); 1111 else 1112 Result := cond_wait 1113 (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L.L'Access); 1114 end if; 1115 1116 pragma Assert (Record_Wakeup 1117 (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason)); 1118 pragma Assert (Result = 0 or else Result = EINTR); 1119 end Sleep; 1120 1121 -- Note that we are relying heaviliy here on the GNAT feature 1122 -- that Calendar.Time, System.Real_Time.Time, Duration, and 1123 -- System.Real_Time.Time_Span are all represented in the same 1124 -- way, i.e., as a 64-bit count of nanoseconds. 1125 1126 -- This allows us to always pass the timeout value as a Duration. 1127 1128 -- ??? 1129 -- We are taking liberties here with the semantics of the delays. 1130 -- That is, we make no distinction between delays on the Calendar clock 1131 -- and delays on the Real_Time clock. That is technically incorrect, if 1132 -- the Calendar clock happens to be reset or adjusted. 1133 -- To solve this defect will require modification to the compiler 1134 -- interface, so that it can pass through more information, to tell 1135 -- us here which clock to use! 1136 1137 -- cond_timedwait will return if any of the following happens: 1138 -- 1) some other task did cond_signal on this condition variable 1139 -- In this case, the return value is 0 1140 -- 2) the call just returned, for no good reason 1141 -- This is called a "spurious wakeup". 1142 -- In this case, the return value may also be 0. 1143 -- 3) the time delay expires 1144 -- In this case, the return value is ETIME 1145 -- 4) this task received a signal, which was handled by some 1146 -- handler procedure, and now the thread is resuming execution 1147 -- UNIX calls this an "interrupted" system call. 1148 -- In this case, the return value is EINTR 1149 1150 -- If the cond_timedwait returns 0 or EINTR, it is still 1151 -- possible that the time has actually expired, and by chance 1152 -- a signal or cond_signal occurred at around the same time. 1153 1154 -- We have also observed that on some OS's the value ETIME 1155 -- will be returned, but the clock will show that the full delay 1156 -- has not yet expired. 1157 1158 -- For these reasons, we need to check the clock after return 1159 -- from cond_timedwait. If the time has expired, we will set 1160 -- Timedout = True. 1161 1162 -- This check might be omitted for systems on which the 1163 -- cond_timedwait() never returns early or wakes up spuriously. 1164 1165 -- Annex D requires that completion of a delay cause the task 1166 -- to go to the end of its priority queue, regardless of whether 1167 -- the task actually was suspended by the delay. Since 1168 -- cond_timedwait does not do this on Solaris, we add a call 1169 -- to thr_yield at the end. We might do this at the beginning, 1170 -- instead, but then the round-robin effect would not be the 1171 -- same; the delayed task would be ahead of other tasks of the 1172 -- same priority that awoke while it was sleeping. 1173 1174 -- For Timed_Sleep, we are expecting possible cond_signals 1175 -- to indicate other events (e.g., completion of a RV or 1176 -- completion of the abortable part of an async. select), 1177 -- we want to always return if interrupted. The caller will 1178 -- be responsible for checking the task state to see whether 1179 -- the wakeup was spurious, and to go back to sleep again 1180 -- in that case. We don't need to check for pending abort 1181 -- or priority change on the way in our out; that is the 1182 -- caller's responsibility. 1183 1184 -- For Timed_Delay, we are not expecting any cond_signals or 1185 -- other interruptions, except for priority changes and aborts. 1186 -- Therefore, we don't want to return unless the delay has 1187 -- actually expired, or the call has been aborted. In this 1188 -- case, since we want to implement the entire delay statement 1189 -- semantics, we do need to check for pending abort and priority 1190 -- changes. We can quietly handle priority changes inside the 1191 -- procedure, since there is no entry-queue reordering involved. 1192 1193 ----------------- 1194 -- Timed_Sleep -- 1195 ----------------- 1196 1197 procedure Timed_Sleep 1198 (Self_ID : Task_ID; 1199 Time : Duration; 1200 Mode : ST.Delay_Modes; 1201 Reason : System.Tasking.Task_States; 1202 Timedout : out Boolean; 1203 Yielded : out Boolean) 1204 is 1205 Check_Time : constant Duration := Monotonic_Clock; 1206 Abs_Time : Duration; 1207 Request : aliased timespec; 1208 Result : Interfaces.C.int; 1209 1210 begin 1211 pragma Assert (Check_Sleep (Reason)); 1212 Timedout := True; 1213 Yielded := False; 1214 1215 if Mode = Relative then 1216 Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; 1217 else 1218 Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); 1219 end if; 1220 1221 if Abs_Time > Check_Time then 1222 Request := To_Timespec (Abs_Time); 1223 1224 loop 1225 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level 1226 or else (Dynamic_Priority_Support and then 1227 Self_ID.Pending_Priority_Change); 1228 1229 if Single_Lock then 1230 Result := cond_timedwait (Self_ID.Common.LL.CV'Access, 1231 Single_RTS_Lock.L'Access, Request'Access); 1232 else 1233 Result := cond_timedwait (Self_ID.Common.LL.CV'Access, 1234 Self_ID.Common.LL.L.L'Access, Request'Access); 1235 end if; 1236 1237 Yielded := True; 1238 1239 exit when Abs_Time <= Monotonic_Clock; 1240 1241 if Result = 0 or Result = EINTR then 1242 1243 -- Somebody may have called Wakeup for us 1244 1245 Timedout := False; 1246 exit; 1247 end if; 1248 1249 pragma Assert (Result = ETIME); 1250 end loop; 1251 end if; 1252 1253 pragma Assert (Record_Wakeup 1254 (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason)); 1255 end Timed_Sleep; 1256 1257 ----------------- 1258 -- Timed_Delay -- 1259 ----------------- 1260 1261 procedure Timed_Delay 1262 (Self_ID : Task_ID; 1263 Time : Duration; 1264 Mode : ST.Delay_Modes) 1265 is 1266 Check_Time : constant Duration := Monotonic_Clock; 1267 Abs_Time : Duration; 1268 Request : aliased timespec; 1269 Result : Interfaces.C.int; 1270 Yielded : Boolean := False; 1271 1272 begin 1273 -- Only the little window between deferring abort and 1274 -- locking Self_ID is the reason we need to 1275 -- check for pending abort and priority change below! 1276 1277 SSL.Abort_Defer.all; 1278 1279 if Single_Lock then 1280 Lock_RTS; 1281 end if; 1282 1283 Write_Lock (Self_ID); 1284 1285 if Mode = Relative then 1286 Abs_Time := Time + Check_Time; 1287 else 1288 Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); 1289 end if; 1290 1291 if Abs_Time > Check_Time then 1292 Request := To_Timespec (Abs_Time); 1293 Self_ID.Common.State := Delay_Sleep; 1294 1295 pragma Assert (Check_Sleep (Delay_Sleep)); 1296 1297 loop 1298 if Dynamic_Priority_Support and then 1299 Self_ID.Pending_Priority_Change then 1300 Self_ID.Pending_Priority_Change := False; 1301 Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; 1302 Set_Priority (Self_ID, Self_ID.Common.Base_Priority); 1303 end if; 1304 1305 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; 1306 1307 if Single_Lock then 1308 Result := cond_timedwait (Self_ID.Common.LL.CV'Access, 1309 Single_RTS_Lock.L'Access, Request'Access); 1310 else 1311 Result := cond_timedwait (Self_ID.Common.LL.CV'Access, 1312 Self_ID.Common.LL.L.L'Access, Request'Access); 1313 end if; 1314 1315 Yielded := True; 1316 1317 exit when Abs_Time <= Monotonic_Clock; 1318 1319 pragma Assert (Result = 0 or else 1320 Result = ETIME or else 1321 Result = EINTR); 1322 end loop; 1323 1324 pragma Assert (Record_Wakeup 1325 (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Delay_Sleep)); 1326 1327 Self_ID.Common.State := Runnable; 1328 end if; 1329 1330 Unlock (Self_ID); 1331 1332 if Single_Lock then 1333 Unlock_RTS; 1334 end if; 1335 1336 if not Yielded then 1337 thr_yield; 1338 end if; 1339 1340 SSL.Abort_Undefer.all; 1341 end Timed_Delay; 1342 1343 ------------ 1344 -- Wakeup -- 1345 ------------ 1346 1347 procedure Wakeup 1348 (T : Task_ID; 1349 Reason : Task_States) 1350 is 1351 Result : Interfaces.C.int; 1352 1353 begin 1354 pragma Assert (Check_Wakeup (T, Reason)); 1355 Result := cond_signal (T.Common.LL.CV'Access); 1356 pragma Assert (Result = 0); 1357 end Wakeup; 1358 1359 --------------------------- 1360 -- Check_Initialize_Lock -- 1361 --------------------------- 1362 1363 -- The following code is intended to check some of the invariant 1364 -- assertions related to lock usage, on which we depend. 1365 1366 function Check_Initialize_Lock 1367 (L : Lock_Ptr; 1368 Level : Lock_Level) 1369 return Boolean 1370 is 1371 Self_ID : constant Task_ID := Self; 1372 1373 begin 1374 -- Check that caller is abort-deferred 1375 1376 if Self_ID.Deferral_Level <= 0 then 1377 return False; 1378 end if; 1379 1380 -- Check that the lock is not yet initialized 1381 1382 if L.Level /= 0 then 1383 return False; 1384 end if; 1385 1386 L.Level := Lock_Level'Pos (Level) + 1; 1387 return True; 1388 end Check_Initialize_Lock; 1389 1390 ---------------- 1391 -- Check_Lock -- 1392 ---------------- 1393 1394 function Check_Lock (L : Lock_Ptr) return Boolean is 1395 Self_ID : constant Task_ID := Self; 1396 P : Lock_Ptr; 1397 1398 begin 1399 -- Check that the argument is not null 1400 1401 if L = null then 1402 return False; 1403 end if; 1404 1405 -- Check that L is not frozen 1406 1407 if L.Frozen then 1408 return False; 1409 end if; 1410 1411 -- Check that caller is abort-deferred 1412 1413 if Self_ID.Deferral_Level <= 0 then 1414 return False; 1415 end if; 1416 1417 -- Check that caller is not holding this lock already 1418 1419 if L.Owner = To_Owner_ID (Self_ID) then 1420 return False; 1421 end if; 1422 1423 if Single_Lock then 1424 return True; 1425 end if; 1426 1427 -- Check that TCB lock order rules are satisfied 1428 1429 P := Self_ID.Common.LL.Locks; 1430 if P /= null then 1431 if P.Level >= L.Level 1432 and then (P.Level > 2 or else L.Level > 2) 1433 then 1434 return False; 1435 end if; 1436 end if; 1437 1438 return True; 1439 end Check_Lock; 1440 1441 ----------------- 1442 -- Record_Lock -- 1443 ----------------- 1444 1445 function Record_Lock (L : Lock_Ptr) return Boolean is 1446 Self_ID : Task_ID := Self; 1447 P : Lock_Ptr; 1448 1449 begin 1450 Lock_Count := Lock_Count + 1; 1451 1452 -- There should be no owner for this lock at this point 1453 1454 if L.Owner /= null then 1455 return False; 1456 end if; 1457 1458 -- Record new owner 1459 1460 L.Owner := To_Owner_ID (Self_ID); 1461 1462 if Single_Lock then 1463 return True; 1464 end if; 1465 1466 -- Check that TCB lock order rules are satisfied 1467 1468 P := Self_ID.Common.LL.Locks; 1469 1470 if P /= null then 1471 L.Next := P; 1472 end if; 1473 1474 Self_ID.Common.LL.Locking := null; 1475 Self_ID.Common.LL.Locks := L; 1476 return True; 1477 end Record_Lock; 1478 1479 ----------------- 1480 -- Check_Sleep -- 1481 ----------------- 1482 1483 function Check_Sleep (Reason : Task_States) return Boolean is 1484 pragma Unreferenced (Reason); 1485 1486 Self_ID : Task_ID := Self; 1487 P : Lock_Ptr; 1488 1489 begin 1490 -- Check that caller is abort-deferred 1491 1492 if Self_ID.Deferral_Level <= 0 then 1493 return False; 1494 end if; 1495 1496 if Single_Lock then 1497 return True; 1498 end if; 1499 1500 -- Check that caller is holding own lock, on top of list 1501 1502 if Self_ID.Common.LL.Locks /= 1503 To_Lock_Ptr (Self_ID.Common.LL.L'Access) 1504 then 1505 return False; 1506 end if; 1507 1508 -- Check that TCB lock order rules are satisfied 1509 1510 if Self_ID.Common.LL.Locks.Next /= null then 1511 return False; 1512 end if; 1513 1514 Self_ID.Common.LL.L.Owner := null; 1515 P := Self_ID.Common.LL.Locks; 1516 Self_ID.Common.LL.Locks := Self_ID.Common.LL.Locks.Next; 1517 P.Next := null; 1518 return True; 1519 end Check_Sleep; 1520 1521 ------------------- 1522 -- Record_Wakeup -- 1523 ------------------- 1524 1525 function Record_Wakeup 1526 (L : Lock_Ptr; 1527 Reason : Task_States) 1528 return Boolean 1529 is 1530 pragma Unreferenced (Reason); 1531 1532 Self_ID : Task_ID := Self; 1533 P : Lock_Ptr; 1534 1535 begin 1536 -- Record new owner 1537 1538 L.Owner := To_Owner_ID (Self_ID); 1539 1540 if Single_Lock then 1541 return True; 1542 end if; 1543 1544 -- Check that TCB lock order rules are satisfied 1545 1546 P := Self_ID.Common.LL.Locks; 1547 1548 if P /= null then 1549 L.Next := P; 1550 end if; 1551 1552 Self_ID.Common.LL.Locking := null; 1553 Self_ID.Common.LL.Locks := L; 1554 return True; 1555 end Record_Wakeup; 1556 1557 ------------------ 1558 -- Check_Wakeup -- 1559 ------------------ 1560 1561 function Check_Wakeup 1562 (T : Task_ID; 1563 Reason : Task_States) 1564 return Boolean 1565 is 1566 Self_ID : constant Task_ID := Self; 1567 1568 begin 1569 -- Is caller holding T's lock? 1570 1571 if T.Common.LL.L.Owner /= To_Owner_ID (Self_ID) then 1572 return False; 1573 end if; 1574 1575 -- Are reasons for wakeup and sleep consistent? 1576 1577 if T.Common.State /= Reason then 1578 return False; 1579 end if; 1580 1581 return True; 1582 end Check_Wakeup; 1583 1584 ------------------ 1585 -- Check_Unlock -- 1586 ------------------ 1587 1588 function Check_Unlock (L : Lock_Ptr) return Boolean is 1589 Self_ID : Task_ID := Self; 1590 P : Lock_Ptr; 1591 1592 begin 1593 Unlock_Count := Unlock_Count + 1; 1594 1595 if L = null then 1596 return False; 1597 end if; 1598 1599 if L.Buddy /= null then 1600 return False; 1601 end if; 1602 1603 if L.Level = 4 then 1604 Check_Count := Unlock_Count; 1605 end if; 1606 1607 if Unlock_Count - Check_Count > 1000 then 1608 Check_Count := Unlock_Count; 1609 end if; 1610 1611 -- Check that caller is abort-deferred 1612 1613 if Self_ID.Deferral_Level <= 0 then 1614 return False; 1615 end if; 1616 1617 -- Check that caller is holding this lock, on top of list 1618 1619 if Self_ID.Common.LL.Locks /= L then 1620 return False; 1621 end if; 1622 1623 -- Record there is no owner now 1624 1625 L.Owner := null; 1626 P := Self_ID.Common.LL.Locks; 1627 Self_ID.Common.LL.Locks := Self_ID.Common.LL.Locks.Next; 1628 P.Next := null; 1629 return True; 1630 end Check_Unlock; 1631 1632 -------------------- 1633 -- Check_Finalize -- 1634 -------------------- 1635 1636 function Check_Finalize_Lock (L : Lock_Ptr) return Boolean is 1637 Self_ID : constant Task_ID := Self; 1638 1639 begin 1640 -- Check that caller is abort-deferred 1641 1642 if Self_ID.Deferral_Level <= 0 then 1643 return False; 1644 end if; 1645 1646 -- Check that no one is holding this lock 1647 1648 if L.Owner /= null then 1649 return False; 1650 end if; 1651 1652 L.Frozen := True; 1653 return True; 1654 end Check_Finalize_Lock; 1655 1656 ---------------- 1657 -- Check_Exit -- 1658 ---------------- 1659 1660 function Check_Exit (Self_ID : Task_ID) return Boolean is 1661 begin 1662 -- Check that caller is just holding Global_Task_Lock 1663 -- and no other locks 1664 1665 if Self_ID.Common.LL.Locks = null then 1666 return False; 1667 end if; 1668 1669 -- 2 = Global_Task_Level 1670 1671 if Self_ID.Common.LL.Locks.Level /= 2 then 1672 return False; 1673 end if; 1674 1675 if Self_ID.Common.LL.Locks.Next /= null then 1676 return False; 1677 end if; 1678 1679 -- Check that caller is abort-deferred 1680 1681 if Self_ID.Deferral_Level <= 0 then 1682 return False; 1683 end if; 1684 1685 return True; 1686 end Check_Exit; 1687 1688 -------------------- 1689 -- Check_No_Locks -- 1690 -------------------- 1691 1692 function Check_No_Locks (Self_ID : Task_ID) return Boolean is 1693 begin 1694 return Self_ID.Common.LL.Locks = null; 1695 end Check_No_Locks; 1696 1697 ---------------------- 1698 -- Environment_Task -- 1699 ---------------------- 1700 1701 function Environment_Task return Task_ID is 1702 begin 1703 return Environment_Task_ID; 1704 end Environment_Task; 1705 1706 -------------- 1707 -- Lock_RTS -- 1708 -------------- 1709 1710 procedure Lock_RTS is 1711 begin 1712 Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); 1713 end Lock_RTS; 1714 1715 ---------------- 1716 -- Unlock_RTS -- 1717 ---------------- 1718 1719 procedure Unlock_RTS is 1720 begin 1721 Unlock (Single_RTS_Lock'Access, Global_Lock => True); 1722 end Unlock_RTS; 1723 1724 ------------------ 1725 -- Suspend_Task -- 1726 ------------------ 1727 1728 function Suspend_Task 1729 (T : ST.Task_ID; 1730 Thread_Self : Thread_Id) 1731 return Boolean 1732 is 1733 begin 1734 if T.Common.LL.Thread /= Thread_Self then 1735 return thr_suspend (T.Common.LL.Thread) = 0; 1736 else 1737 return True; 1738 end if; 1739 end Suspend_Task; 1740 1741 ----------------- 1742 -- Resume_Task -- 1743 ----------------- 1744 1745 function Resume_Task 1746 (T : ST.Task_ID; 1747 Thread_Self : Thread_Id) 1748 return Boolean 1749 is 1750 begin 1751 if T.Common.LL.Thread /= Thread_Self then 1752 return thr_continue (T.Common.LL.Thread) = 0; 1753 else 1754 return True; 1755 end if; 1756 end Resume_Task; 1757 1758-- Package elaboration 1759 1760begin 1761 declare 1762 Result : Interfaces.C.int; 1763 1764 begin 1765 -- Mask Environment task for all signals. The original mask of the 1766 -- Environment task will be recovered by Interrupt_Server task 1767 -- during the elaboration of s-interr.adb. 1768 1769 System.Interrupt_Management.Operations.Set_Interrupt_Mask 1770 (System.Interrupt_Management.Operations.All_Tasks_Mask'Access); 1771 1772 -- Prepare the set of signals that should unblocked in all tasks 1773 1774 Result := sigemptyset (Unblocked_Signal_Mask'Access); 1775 pragma Assert (Result = 0); 1776 1777 for J in Interrupt_Management.Interrupt_ID loop 1778 if System.Interrupt_Management.Keep_Unmasked (J) then 1779 Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); 1780 pragma Assert (Result = 0); 1781 end if; 1782 end loop; 1783 1784 -- We need the following code to support automatic creation of fake 1785 -- ATCB's for C threads that call the Ada run-time system, even if 1786 -- we use a faster way of getting Self for real Ada tasks. 1787 1788 Result := thr_keycreate (ATCB_Key'Access, System.Null_Address); 1789 pragma Assert (Result = 0); 1790 end; 1791 1792 if Dispatching_Policy = 'F' then 1793 declare 1794 Result : Interfaces.C.long; 1795 Class_Info : aliased struct_pcinfo; 1796 Secs, Nsecs : Interfaces.C.long; 1797 1798 begin 1799 -- If a pragma Time_Slice is specified, takes the value in account. 1800 1801 if Time_Slice_Val > 0 then 1802 -- Convert Time_Slice_Val (microseconds) into seconds and 1803 -- nanoseconds 1804 1805 Secs := Time_Slice_Val / 1_000_000; 1806 Nsecs := (Time_Slice_Val rem 1_000_000) * 1_000; 1807 1808 -- Otherwise, default to no time slicing (i.e run until blocked) 1809 1810 else 1811 Secs := RT_TQINF; 1812 Nsecs := RT_TQINF; 1813 end if; 1814 1815 -- Get the real time class id. 1816 1817 Class_Info.pc_clname (1) := 'R'; 1818 Class_Info.pc_clname (2) := 'T'; 1819 Class_Info.pc_clname (3) := ASCII.NUL; 1820 1821 Result := priocntl (PC_VERSION, P_LWPID, P_MYID, PC_GETCID, 1822 Class_Info'Address); 1823 1824 -- Request the real time class 1825 1826 Prio_Param.pc_cid := Class_Info.pc_cid; 1827 Prio_Param.rt_pri := pri_t (Class_Info.rt_maxpri); 1828 Prio_Param.rt_tqsecs := Secs; 1829 Prio_Param.rt_tqnsecs := Nsecs; 1830 1831 Result := priocntl (PC_VERSION, P_LWPID, P_MYID, PC_SETPARMS, 1832 Prio_Param'Address); 1833 1834 Using_Real_Time_Class := Result /= -1; 1835 end; 1836 end if; 1837end System.Task_Primitives.Operations; 1838