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