Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnarl/s-taprop__posix.adb @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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-2017, 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 POSIX-like version of this package
33
34 -- This package contains all the GNULL primitives that interface directly with
35 -- the underlying OS.
36
37 -- Note: this file can only be used for POSIX compliant systems that implement
38 -- SCHED_FIFO and Ceiling Locking correctly.
39
40 -- For configurations where SCHED_FIFO and priority ceiling are not a
41 -- requirement, this file can also be used (e.g AiX threads)
42
43 pragma Polling (Off);
44 -- Turn off polling, we do not want ATC polling to take place during tasking
45 -- operations. It causes infinite loops and other problems.
46
47 with Ada.Unchecked_Conversion;
48
49 with Interfaces.C;
50
51 with System.Tasking.Debug;
52 with System.Interrupt_Management;
53 with System.OS_Constants;
54 with System.OS_Primitives;
55 with System.Task_Info;
56
57 with System.Soft_Links;
58 -- We use System.Soft_Links instead of System.Tasking.Initialization
59 -- because the later is a higher level package that we shouldn't depend on.
60 -- For example when using the restricted run time, it is replaced by
61 -- System.Tasking.Restricted.Stages.
62
63 package body System.Task_Primitives.Operations is
64
65 package OSC renames System.OS_Constants;
66 package SSL renames System.Soft_Links;
67
68 use System.Tasking.Debug;
69 use System.Tasking;
70 use Interfaces.C;
71 use System.OS_Interface;
72 use System.Parameters;
73 use System.OS_Primitives;
74
75 ----------------
76 -- Local Data --
77 ----------------
78
79 -- The followings are logically constants, but need to be initialized
80 -- at run time.
81
82 Single_RTS_Lock : aliased RTS_Lock;
83 -- This is a lock to allow only one thread of control in the RTS at
84 -- a time; it is used to execute in mutual exclusion from all other tasks.
85 -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
86
87 Environment_Task_Id : Task_Id;
88 -- A variable to hold Task_Id for the environment task
89
90 Locking_Policy : Character;
91 pragma Import (C, Locking_Policy, "__gl_locking_policy");
92 -- Value of the pragma Locking_Policy:
93 -- 'C' for Ceiling_Locking
94 -- 'I' for Inherit_Locking
95 -- ' ' for none.
96
97 Unblocked_Signal_Mask : aliased sigset_t;
98 -- The set of signals that should unblocked in all tasks
99
100 -- The followings are internal configuration constants needed
101
102 Next_Serial_Number : Task_Serial_Number := 100;
103 -- We start at 100, to reserve some special values for
104 -- using in error checking.
105
106 Time_Slice_Val : Integer;
107 pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
108
109 Dispatching_Policy : Character;
110 pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
111
112 Foreign_Task_Elaborated : aliased Boolean := True;
113 -- Used to identified fake tasks (i.e., non-Ada Threads)
114
115 Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0;
116 -- Whether to use an alternate signal stack for stack overflows
117
118 Abort_Handler_Installed : Boolean := False;
119 -- True if a handler for the abort signal is installed
120
121 --------------------
122 -- Local Packages --
123 --------------------
124
125 package Specific is
126
127 procedure Initialize (Environment_Task : Task_Id);
128 pragma Inline (Initialize);
129 -- Initialize various data needed by this package
130
131 function Is_Valid_Task return Boolean;
132 pragma Inline (Is_Valid_Task);
133 -- Does executing thread have a TCB?
134
135 procedure Set (Self_Id : Task_Id);
136 pragma Inline (Set);
137 -- Set the self id for the current task
138
139 function Self return Task_Id;
140 pragma Inline (Self);
141 -- Return a pointer to the Ada Task Control Block of the calling task
142
143 end Specific;
144
145 package body Specific is separate;
146 -- The body of this package is target specific
147
148 package Monotonic is
149
150 function Monotonic_Clock return Duration;
151 pragma Inline (Monotonic_Clock);
152 -- Returns "absolute" time, represented as an offset relative to "the
153 -- Epoch", which is Jan 1, 1970. This clock implementation is immune to
154 -- the system's clock changes.
155
156 function RT_Resolution return Duration;
157 pragma Inline (RT_Resolution);
158 -- Returns resolution of the underlying clock used to implement RT_Clock
159
160 procedure Timed_Sleep
161 (Self_ID : ST.Task_Id;
162 Time : Duration;
163 Mode : ST.Delay_Modes;
164 Reason : System.Tasking.Task_States;
165 Timedout : out Boolean;
166 Yielded : out Boolean);
167 -- Combination of Sleep (above) and Timed_Delay
168
169 procedure Timed_Delay
170 (Self_ID : ST.Task_Id;
171 Time : Duration;
172 Mode : ST.Delay_Modes);
173 -- Implement the semantics of the delay statement.
174 -- The caller should be abort-deferred and should not hold any locks.
175
176 end Monotonic;
177
178 package body Monotonic is separate;
179
180 ----------------------------------
181 -- ATCB allocation/deallocation --
182 ----------------------------------
183
184 package body ATCB_Allocation is separate;
185 -- The body of this package is shared across several targets
186
187 ---------------------------------
188 -- Support for foreign threads --
189 ---------------------------------
190
191 function Register_Foreign_Thread
192 (Thread : Thread_Id;
193 Sec_Stack_Size : Size_Type := Unspecified_Size) return Task_Id;
194 -- Allocate and initialize a new ATCB for the current Thread. The size of
195 -- the secondary stack can be optionally specified.
196
197 function Register_Foreign_Thread
198 (Thread : Thread_Id;
199 Sec_Stack_Size : Size_Type := Unspecified_Size)
200 return Task_Id is separate;
201
202 -----------------------
203 -- Local Subprograms --
204 -----------------------
205
206 procedure Abort_Handler (Sig : Signal);
207 -- Signal handler used to implement asynchronous abort.
208 -- See also comment before body, below.
209
210 function To_Address is
211 new Ada.Unchecked_Conversion (Task_Id, System.Address);
212
213 function GNAT_pthread_condattr_setup
214 (attr : access pthread_condattr_t) return int;
215 pragma Import (C,
216 GNAT_pthread_condattr_setup, "__gnat_pthread_condattr_setup");
217
218 -------------------
219 -- Abort_Handler --
220 -------------------
221
222 -- Target-dependent binding of inter-thread Abort signal to the raising of
223 -- the Abort_Signal exception.
224
225 -- The technical issues and alternatives here are essentially the
226 -- same as for raising exceptions in response to other signals
227 -- (e.g. Storage_Error). See code and comments in the package body
228 -- System.Interrupt_Management.
229
230 -- Some implementations may not allow an exception to be propagated out of
231 -- a handler, and others might leave the signal or interrupt that invoked
232 -- this handler masked after the exceptional return to the application
233 -- code.
234
235 -- GNAT exceptions are originally implemented using setjmp()/longjmp(). On
236 -- most UNIX systems, this will allow transfer out of a signal handler,
237 -- which is usually the only mechanism available for implementing
238 -- asynchronous handlers of this kind. However, some systems do not
239 -- restore the signal mask on longjmp(), leaving the abort signal masked.
240
241 procedure Abort_Handler (Sig : Signal) is
242 pragma Unreferenced (Sig);
243
244 T : constant Task_Id := Self;
245 Old_Set : aliased sigset_t;
246
247 Result : Interfaces.C.int;
248 pragma Warnings (Off, Result);
249
250 begin
251 -- It's not safe to raise an exception when using GCC ZCX mechanism.
252 -- Note that we still need to install a signal handler, since in some
253 -- cases (e.g. shutdown of the Server_Task in System.Interrupts) we
254 -- need to send the Abort signal to a task.
255
256 if ZCX_By_Default then
257 return;
258 end if;
259
260 if T.Deferral_Level = 0
261 and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then
262 not T.Aborting
263 then
264 T.Aborting := True;
265
266 -- Make sure signals used for RTS internal purpose are unmasked
267
268 Result := pthread_sigmask (SIG_UNBLOCK,
269 Unblocked_Signal_Mask'Access, Old_Set'Access);
270 pragma Assert (Result = 0);
271
272 raise Standard'Abort_Signal;
273 end if;
274 end Abort_Handler;
275
276 -----------------
277 -- Stack_Guard --
278 -----------------
279
280 procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
281 Stack_Base : constant Address := Get_Stack_Base (T.Common.LL.Thread);
282 Page_Size : Address;
283 Res : Interfaces.C.int;
284
285 begin
286 if Stack_Base_Available then
287
288 -- Compute the guard page address
289
290 Page_Size := Address (Get_Page_Size);
291 Res :=
292 mprotect
293 (Stack_Base - (Stack_Base mod Page_Size) + Page_Size,
294 size_t (Page_Size),
295 prot => (if On then PROT_ON else PROT_OFF));
296 pragma Assert (Res = 0);
297 end if;
298 end Stack_Guard;
299
300 --------------------
301 -- Get_Thread_Id --
302 --------------------
303
304 function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
305 begin
306 return T.Common.LL.Thread;
307 end Get_Thread_Id;
308
309 ----------
310 -- Self --
311 ----------
312
313 function Self return Task_Id renames Specific.Self;
314
315 ---------------------
316 -- Initialize_Lock --
317 ---------------------
318
319 -- Note: mutexes and cond_variables needed per-task basis are initialized
320 -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
321 -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any
322 -- status change of RTS. Therefore raising Storage_Error in the following
323 -- routines should be able to be handled safely.
324
325 procedure Initialize_Lock
326 (Prio : System.Any_Priority;
327 L : not null access Lock)
328 is
329 Attributes : aliased pthread_mutexattr_t;
330 Result : Interfaces.C.int;
331
332 begin
333 Result := pthread_mutexattr_init (Attributes'Access);
334 pragma Assert (Result = 0 or else Result = ENOMEM);
335
336 if Result = ENOMEM then
337 raise Storage_Error;
338 end if;
339
340 if Locking_Policy = 'C' then
341 Result := pthread_mutexattr_setprotocol
342 (Attributes'Access, PTHREAD_PRIO_PROTECT);
343 pragma Assert (Result = 0);
344
345 Result := pthread_mutexattr_setprioceiling
346 (Attributes'Access, Interfaces.C.int (Prio));
347 pragma Assert (Result = 0);
348
349 elsif Locking_Policy = 'I' then
350 Result := pthread_mutexattr_setprotocol
351 (Attributes'Access, PTHREAD_PRIO_INHERIT);
352 pragma Assert (Result = 0);
353 end if;
354
355 Result := pthread_mutex_init (L.WO'Access, Attributes'Access);
356 pragma Assert (Result = 0 or else Result = ENOMEM);
357
358 if Result = ENOMEM then
359 Result := pthread_mutexattr_destroy (Attributes'Access);
360 raise Storage_Error;
361 end if;
362
363 Result := pthread_mutexattr_destroy (Attributes'Access);
364 pragma Assert (Result = 0);
365 end Initialize_Lock;
366
367 procedure Initialize_Lock
368 (L : not null access RTS_Lock; Level : Lock_Level)
369 is
370 pragma Unreferenced (Level);
371
372 Attributes : aliased pthread_mutexattr_t;
373 Result : Interfaces.C.int;
374
375 begin
376 Result := pthread_mutexattr_init (Attributes'Access);
377 pragma Assert (Result = 0 or else Result = ENOMEM);
378
379 if Result = ENOMEM then
380 raise Storage_Error;
381 end if;
382
383 if Locking_Policy = 'C' then
384 Result := pthread_mutexattr_setprotocol
385 (Attributes'Access, PTHREAD_PRIO_PROTECT);
386 pragma Assert (Result = 0);
387
388 Result := pthread_mutexattr_setprioceiling
389 (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last));
390 pragma Assert (Result = 0);
391
392 elsif Locking_Policy = 'I' then
393 Result := pthread_mutexattr_setprotocol
394 (Attributes'Access, PTHREAD_PRIO_INHERIT);
395 pragma Assert (Result = 0);
396 end if;
397
398 Result := pthread_mutex_init (L, Attributes'Access);
399 pragma Assert (Result = 0 or else Result = ENOMEM);
400
401 if Result = ENOMEM then
402 Result := pthread_mutexattr_destroy (Attributes'Access);
403 raise Storage_Error;
404 end if;
405
406 Result := pthread_mutexattr_destroy (Attributes'Access);
407 pragma Assert (Result = 0);
408 end Initialize_Lock;
409
410 -------------------
411 -- Finalize_Lock --
412 -------------------
413
414 procedure Finalize_Lock (L : not null access Lock) is
415 Result : Interfaces.C.int;
416 begin
417 Result := pthread_mutex_destroy (L.WO'Access);
418 pragma Assert (Result = 0);
419 end Finalize_Lock;
420
421 procedure Finalize_Lock (L : not null access RTS_Lock) is
422 Result : Interfaces.C.int;
423 begin
424 Result := pthread_mutex_destroy (L);
425 pragma Assert (Result = 0);
426 end Finalize_Lock;
427
428 ----------------
429 -- Write_Lock --
430 ----------------
431
432 procedure Write_Lock
433 (L : not null access Lock; Ceiling_Violation : out Boolean)
434 is
435 Result : Interfaces.C.int;
436
437 begin
438 Result := pthread_mutex_lock (L.WO'Access);
439
440 -- The cause of EINVAL is a priority ceiling violation
441
442 Ceiling_Violation := Result = EINVAL;
443 pragma Assert (Result = 0 or else Ceiling_Violation);
444 end Write_Lock;
445
446 procedure Write_Lock
447 (L : not null access RTS_Lock;
448 Global_Lock : Boolean := False)
449 is
450 Result : Interfaces.C.int;
451 begin
452 if not Single_Lock or else Global_Lock then
453 Result := pthread_mutex_lock (L);
454 pragma Assert (Result = 0);
455 end if;
456 end Write_Lock;
457
458 procedure Write_Lock (T : Task_Id) is
459 Result : Interfaces.C.int;
460 begin
461 if not Single_Lock then
462 Result := pthread_mutex_lock (T.Common.LL.L'Access);
463 pragma Assert (Result = 0);
464 end if;
465 end Write_Lock;
466
467 ---------------
468 -- Read_Lock --
469 ---------------
470
471 procedure Read_Lock
472 (L : not null access Lock; Ceiling_Violation : out Boolean) is
473 begin
474 Write_Lock (L, Ceiling_Violation);
475 end Read_Lock;
476
477 ------------
478 -- Unlock --
479 ------------
480
481 procedure Unlock (L : not null access Lock) is
482 Result : Interfaces.C.int;
483 begin
484 Result := pthread_mutex_unlock (L.WO'Access);
485 pragma Assert (Result = 0);
486 end Unlock;
487
488 procedure Unlock
489 (L : not null access RTS_Lock; Global_Lock : Boolean := False)
490 is
491 Result : Interfaces.C.int;
492 begin
493 if not Single_Lock or else Global_Lock then
494 Result := pthread_mutex_unlock (L);
495 pragma Assert (Result = 0);
496 end if;
497 end Unlock;
498
499 procedure Unlock (T : Task_Id) is
500 Result : Interfaces.C.int;
501 begin
502 if not Single_Lock then
503 Result := pthread_mutex_unlock (T.Common.LL.L'Access);
504 pragma Assert (Result = 0);
505 end if;
506 end Unlock;
507
508 -----------------
509 -- Set_Ceiling --
510 -----------------
511
512 -- Dynamic priority ceilings are not supported by the underlying system
513
514 procedure Set_Ceiling
515 (L : not null access Lock;
516 Prio : System.Any_Priority)
517 is
518 pragma Unreferenced (L, Prio);
519 begin
520 null;
521 end Set_Ceiling;
522
523 -----------
524 -- Sleep --
525 -----------
526
527 procedure Sleep
528 (Self_ID : Task_Id;
529 Reason : System.Tasking.Task_States)
530 is
531 pragma Unreferenced (Reason);
532
533 Result : Interfaces.C.int;
534
535 begin
536 Result :=
537 pthread_cond_wait
538 (cond => Self_ID.Common.LL.CV'Access,
539 mutex => (if Single_Lock
540 then Single_RTS_Lock'Access
541 else Self_ID.Common.LL.L'Access));
542
543 -- EINTR is not considered a failure
544
545 pragma Assert (Result = 0 or else Result = EINTR);
546 end Sleep;
547
548 -----------------
549 -- Timed_Sleep --
550 -----------------
551
552 -- This is for use within the run-time system, so abort is
553 -- assumed to be already deferred, and the caller should be
554 -- holding its own ATCB lock.
555
556 procedure Timed_Sleep
557 (Self_ID : Task_Id;
558 Time : Duration;
559 Mode : ST.Delay_Modes;
560 Reason : Task_States;
561 Timedout : out Boolean;
562 Yielded : out Boolean) renames Monotonic.Timed_Sleep;
563
564 -----------------
565 -- Timed_Delay --
566 -----------------
567
568 -- This is for use in implementing delay statements, so we assume the
569 -- caller is abort-deferred but is holding no locks.
570
571 procedure Timed_Delay
572 (Self_ID : Task_Id;
573 Time : Duration;
574 Mode : ST.Delay_Modes) renames Monotonic.Timed_Delay;
575
576 ---------------------
577 -- Monotonic_Clock --
578 ---------------------
579
580 function Monotonic_Clock return Duration renames Monotonic.Monotonic_Clock;
581
582 -------------------
583 -- RT_Resolution --
584 -------------------
585
586 function RT_Resolution return Duration renames Monotonic.RT_Resolution;
587
588 ------------
589 -- Wakeup --
590 ------------
591
592 procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
593 pragma Unreferenced (Reason);
594 Result : Interfaces.C.int;
595 begin
596 Result := pthread_cond_signal (T.Common.LL.CV'Access);
597 pragma Assert (Result = 0);
598 end Wakeup;
599
600 -----------
601 -- Yield --
602 -----------
603
604 procedure Yield (Do_Yield : Boolean := True) is
605 Result : Interfaces.C.int;
606 pragma Unreferenced (Result);
607 begin
608 if Do_Yield then
609 Result := sched_yield;
610 end if;
611 end Yield;
612
613 ------------------
614 -- Set_Priority --
615 ------------------
616
617 procedure Set_Priority
618 (T : Task_Id;
619 Prio : System.Any_Priority;
620 Loss_Of_Inheritance : Boolean := False)
621 is
622 pragma Unreferenced (Loss_Of_Inheritance);
623
624 Result : Interfaces.C.int;
625 Param : aliased struct_sched_param;
626
627 function Get_Policy (Prio : System.Any_Priority) return Character;
628 pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
629 -- Get priority specific dispatching policy
630
631 Priority_Specific_Policy : constant Character := Get_Policy (Prio);
632 -- Upper case first character of the policy name corresponding to the
633 -- task as set by a Priority_Specific_Dispatching pragma.
634
635 begin
636 T.Common.Current_Priority := Prio;
637 Param.sched_priority := To_Target_Priority (Prio);
638
639 if Time_Slice_Supported
640 and then (Dispatching_Policy = 'R'
641 or else Priority_Specific_Policy = 'R'
642 or else Time_Slice_Val > 0)
643 then
644 Result := pthread_setschedparam
645 (T.Common.LL.Thread, SCHED_RR, Param'Access);
646
647 elsif Dispatching_Policy = 'F'
648 or else Priority_Specific_Policy = 'F'
649 or else Time_Slice_Val = 0
650 then
651 Result := pthread_setschedparam
652 (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
653
654 else
655 Result := pthread_setschedparam
656 (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
657 end if;
658
659 pragma Assert (Result = 0);
660 end Set_Priority;
661
662 ------------------
663 -- Get_Priority --
664 ------------------
665
666 function Get_Priority (T : Task_Id) return System.Any_Priority is
667 begin
668 return T.Common.Current_Priority;
669 end Get_Priority;
670
671 ----------------
672 -- Enter_Task --
673 ----------------
674
675 procedure Enter_Task (Self_ID : Task_Id) is
676 begin
677 Self_ID.Common.LL.Thread := pthread_self;
678 Self_ID.Common.LL.LWP := lwp_self;
679
680 Specific.Set (Self_ID);
681
682 if Use_Alternate_Stack then
683 declare
684 Stack : aliased stack_t;
685 Result : Interfaces.C.int;
686 begin
687 Stack.ss_sp := Self_ID.Common.Task_Alternate_Stack;
688 Stack.ss_size := Alternate_Stack_Size;
689 Stack.ss_flags := 0;
690 Result := sigaltstack (Stack'Access, null);
691 pragma Assert (Result = 0);
692 end;
693 end if;
694 end Enter_Task;
695
696 -------------------
697 -- Is_Valid_Task --
698 -------------------
699
700 function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
701
702 -----------------------------
703 -- Register_Foreign_Thread --
704 -----------------------------
705
706 function Register_Foreign_Thread return Task_Id is
707 begin
708 if Is_Valid_Task then
709 return Self;
710 else
711 return Register_Foreign_Thread (pthread_self);
712 end if;
713 end Register_Foreign_Thread;
714
715 --------------------
716 -- Initialize_TCB --
717 --------------------
718
719 procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
720 Mutex_Attr : aliased pthread_mutexattr_t;
721 Result : Interfaces.C.int;
722 Cond_Attr : aliased pthread_condattr_t;
723
724 begin
725 -- Give the task a unique serial number
726
727 Self_ID.Serial_Number := Next_Serial_Number;
728 Next_Serial_Number := Next_Serial_Number + 1;
729 pragma Assert (Next_Serial_Number /= 0);
730
731 if not Single_Lock then
732 Result := pthread_mutexattr_init (Mutex_Attr'Access);
733 pragma Assert (Result = 0 or else Result = ENOMEM);
734
735 if Result = 0 then
736 if Locking_Policy = 'C' then
737 Result :=
738 pthread_mutexattr_setprotocol
739 (Mutex_Attr'Access,
740 PTHREAD_PRIO_PROTECT);
741 pragma Assert (Result = 0);
742
743 Result :=
744 pthread_mutexattr_setprioceiling
745 (Mutex_Attr'Access,
746 Interfaces.C.int (System.Any_Priority'Last));
747 pragma Assert (Result = 0);
748
749 elsif Locking_Policy = 'I' then
750 Result :=
751 pthread_mutexattr_setprotocol
752 (Mutex_Attr'Access,
753 PTHREAD_PRIO_INHERIT);
754 pragma Assert (Result = 0);
755 end if;
756
757 Result :=
758 pthread_mutex_init
759 (Self_ID.Common.LL.L'Access,
760 Mutex_Attr'Access);
761 pragma Assert (Result = 0 or else Result = ENOMEM);
762 end if;
763
764 if Result /= 0 then
765 Succeeded := False;
766 return;
767 end if;
768
769 Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
770 pragma Assert (Result = 0);
771 end if;
772
773 Result := pthread_condattr_init (Cond_Attr'Access);
774 pragma Assert (Result = 0 or else Result = ENOMEM);
775
776 if Result = 0 then
777 Result := GNAT_pthread_condattr_setup (Cond_Attr'Access);
778 pragma Assert (Result = 0);
779
780 Result :=
781 pthread_cond_init
782 (Self_ID.Common.LL.CV'Access, Cond_Attr'Access);
783 pragma Assert (Result = 0 or else Result = ENOMEM);
784 end if;
785
786 if Result = 0 then
787 Succeeded := True;
788 else
789 if not Single_Lock then
790 Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
791 pragma Assert (Result = 0);
792 end if;
793
794 Succeeded := False;
795 end if;
796
797 Result := pthread_condattr_destroy (Cond_Attr'Access);
798 pragma Assert (Result = 0);
799 end Initialize_TCB;
800
801 -----------------
802 -- Create_Task --
803 -----------------
804
805 procedure Create_Task
806 (T : Task_Id;
807 Wrapper : System.Address;
808 Stack_Size : System.Parameters.Size_Type;
809 Priority : System.Any_Priority;
810 Succeeded : out Boolean)
811 is
812 Attributes : aliased pthread_attr_t;
813 Adjusted_Stack_Size : Interfaces.C.size_t;
814 Page_Size : constant Interfaces.C.size_t :=
815 Interfaces.C.size_t (Get_Page_Size);
816 Result : Interfaces.C.int;
817
818 function Thread_Body_Access is new
819 Ada.Unchecked_Conversion (System.Address, Thread_Body);
820
821 use System.Task_Info;
822
823 begin
824 Adjusted_Stack_Size :=
825 Interfaces.C.size_t (Stack_Size + Alternate_Stack_Size);
826
827 if Stack_Base_Available then
828
829 -- If Stack Checking is supported then allocate 2 additional pages:
830
831 -- In the worst case, stack is allocated at something like
832 -- N * Get_Page_Size - epsilon, we need to add the size for 2 pages
833 -- to be sure the effective stack size is greater than what
834 -- has been asked.
835
836 Adjusted_Stack_Size := Adjusted_Stack_Size + 2 * Page_Size;
837 end if;
838
839 -- Round stack size as this is required by some OSes (Darwin)
840
841 Adjusted_Stack_Size := Adjusted_Stack_Size + Page_Size - 1;
842 Adjusted_Stack_Size :=
843 Adjusted_Stack_Size - Adjusted_Stack_Size mod Page_Size;
844
845 Result := pthread_attr_init (Attributes'Access);
846 pragma Assert (Result = 0 or else Result = ENOMEM);
847
848 if Result /= 0 then
849 Succeeded := False;
850 return;
851 end if;
852
853 Result :=
854 pthread_attr_setdetachstate
855 (Attributes'Access, PTHREAD_CREATE_DETACHED);
856 pragma Assert (Result = 0);
857
858 Result :=
859 pthread_attr_setstacksize
860 (Attributes'Access, Adjusted_Stack_Size);
861 pragma Assert (Result = 0);
862
863 if T.Common.Task_Info /= Default_Scope then
864 case T.Common.Task_Info is
865 when System.Task_Info.Process_Scope =>
866 Result :=
867 pthread_attr_setscope
868 (Attributes'Access, PTHREAD_SCOPE_PROCESS);
869
870 when System.Task_Info.System_Scope =>
871 Result :=
872 pthread_attr_setscope
873 (Attributes'Access, PTHREAD_SCOPE_SYSTEM);
874
875 when System.Task_Info.Default_Scope =>
876 Result := 0;
877 end case;
878
879 pragma Assert (Result = 0);
880 end if;
881
882 -- Since the initial signal mask of a thread is inherited from the
883 -- creator, and the Environment task has all its signals masked, we
884 -- do not need to manipulate caller's signal mask at this point.
885 -- All tasks in RTS will have All_Tasks_Mask initially.
886
887 -- Note: the use of Unrestricted_Access in the following call is needed
888 -- because otherwise we have an error of getting a access-to-volatile
889 -- value which points to a non-volatile object. But in this case it is
890 -- safe to do this, since we know we have no problems with aliasing and
891 -- Unrestricted_Access bypasses this check.
892
893 Result := pthread_create
894 (T.Common.LL.Thread'Unrestricted_Access,
895 Attributes'Access,
896 Thread_Body_Access (Wrapper),
897 To_Address (T));
898 pragma Assert (Result = 0 or else Result = EAGAIN);
899
900 Succeeded := Result = 0;
901
902 Result := pthread_attr_destroy (Attributes'Access);
903 pragma Assert (Result = 0);
904
905 if Succeeded then
906 Set_Priority (T, Priority);
907 end if;
908 end Create_Task;
909
910 ------------------
911 -- Finalize_TCB --
912 ------------------
913
914 procedure Finalize_TCB (T : Task_Id) is
915 Result : Interfaces.C.int;
916
917 begin
918 if not Single_Lock then
919 Result := pthread_mutex_destroy (T.Common.LL.L'Access);
920 pragma Assert (Result = 0);
921 end if;
922
923 Result := pthread_cond_destroy (T.Common.LL.CV'Access);
924 pragma Assert (Result = 0);
925
926 if T.Known_Tasks_Index /= -1 then
927 Known_Tasks (T.Known_Tasks_Index) := null;
928 end if;
929
930 ATCB_Allocation.Free_ATCB (T);
931 end Finalize_TCB;
932
933 ---------------
934 -- Exit_Task --
935 ---------------
936
937 procedure Exit_Task is
938 begin
939 -- Mark this task as unknown, so that if Self is called, it won't
940 -- return a dangling pointer.
941
942 Specific.Set (null);
943 end Exit_Task;
944
945 ----------------
946 -- Abort_Task --
947 ----------------
948
949 procedure Abort_Task (T : Task_Id) is
950 Result : Interfaces.C.int;
951 begin
952 if Abort_Handler_Installed then
953 Result :=
954 pthread_kill
955 (T.Common.LL.Thread,
956 Signal (System.Interrupt_Management.Abort_Task_Interrupt));
957 pragma Assert (Result = 0);
958 end if;
959 end Abort_Task;
960
961 ----------------
962 -- Initialize --
963 ----------------
964
965 procedure Initialize (S : in out Suspension_Object) is
966 Mutex_Attr : aliased pthread_mutexattr_t;
967 Cond_Attr : aliased pthread_condattr_t;
968 Result : Interfaces.C.int;
969
970 begin
971 -- Initialize internal state (always to False (RM D.10 (6)))
972
973 S.State := False;
974 S.Waiting := False;
975
976 -- Initialize internal mutex
977
978 Result := pthread_mutexattr_init (Mutex_Attr'Access);
979 pragma Assert (Result = 0 or else Result = ENOMEM);
980
981 if Result = ENOMEM then
982 raise Storage_Error;
983 end if;
984
985 Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access);
986 pragma Assert (Result = 0 or else Result = ENOMEM);
987
988 if Result = ENOMEM then
989 Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
990 pragma Assert (Result = 0);
991
992 raise Storage_Error;
993 end if;
994
995 Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
996 pragma Assert (Result = 0);
997
998 -- Initialize internal condition variable
999
1000 Result := pthread_condattr_init (Cond_Attr'Access);
1001 pragma Assert (Result = 0 or else Result = ENOMEM);
1002
1003 if Result /= 0 then
1004 Result := pthread_mutex_destroy (S.L'Access);
1005 pragma Assert (Result = 0);
1006
1007 -- Storage_Error is propagated as intended if the allocation of the
1008 -- underlying OS entities fails.
1009
1010 raise Storage_Error;
1011
1012 else
1013 Result := GNAT_pthread_condattr_setup (Cond_Attr'Access);
1014 pragma Assert (Result = 0);
1015 end if;
1016
1017 Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access);
1018 pragma Assert (Result = 0 or else Result = ENOMEM);
1019
1020 if Result /= 0 then
1021 Result := pthread_mutex_destroy (S.L'Access);
1022 pragma Assert (Result = 0);
1023
1024 Result := pthread_condattr_destroy (Cond_Attr'Access);
1025 pragma Assert (Result = 0);
1026
1027 -- Storage_Error is propagated as intended if the allocation of the
1028 -- underlying OS entities fails.
1029
1030 raise Storage_Error;
1031 end if;
1032
1033 Result := pthread_condattr_destroy (Cond_Attr'Access);
1034 pragma Assert (Result = 0);
1035 end Initialize;
1036
1037 --------------
1038 -- Finalize --
1039 --------------
1040
1041 procedure Finalize (S : in out Suspension_Object) is
1042 Result : Interfaces.C.int;
1043
1044 begin
1045 -- Destroy internal mutex
1046
1047 Result := pthread_mutex_destroy (S.L'Access);
1048 pragma Assert (Result = 0);
1049
1050 -- Destroy internal condition variable
1051
1052 Result := pthread_cond_destroy (S.CV'Access);
1053 pragma Assert (Result = 0);
1054 end Finalize;
1055
1056 -------------------
1057 -- Current_State --
1058 -------------------
1059
1060 function Current_State (S : Suspension_Object) return Boolean is
1061 begin
1062 -- We do not want to use lock on this read operation. State is marked
1063 -- as Atomic so that we ensure that the value retrieved is correct.
1064
1065 return S.State;
1066 end Current_State;
1067
1068 ---------------
1069 -- Set_False --
1070 ---------------
1071
1072 procedure Set_False (S : in out Suspension_Object) is
1073 Result : Interfaces.C.int;
1074
1075 begin
1076 SSL.Abort_Defer.all;
1077
1078 Result := pthread_mutex_lock (S.L'Access);
1079 pragma Assert (Result = 0);
1080
1081 S.State := False;
1082
1083 Result := pthread_mutex_unlock (S.L'Access);
1084 pragma Assert (Result = 0);
1085
1086 SSL.Abort_Undefer.all;
1087 end Set_False;
1088
1089 --------------
1090 -- Set_True --
1091 --------------
1092
1093 procedure Set_True (S : in out Suspension_Object) is
1094 Result : Interfaces.C.int;
1095
1096 begin
1097 SSL.Abort_Defer.all;
1098
1099 Result := pthread_mutex_lock (S.L'Access);
1100 pragma Assert (Result = 0);
1101
1102 -- If there is already a task waiting on this suspension object then
1103 -- we resume it, leaving the state of the suspension object to False,
1104 -- as it is specified in (RM D.10(9)). Otherwise, it just leaves
1105 -- the state to True.
1106
1107 if S.Waiting then
1108 S.Waiting := False;
1109 S.State := False;
1110
1111 Result := pthread_cond_signal (S.CV'Access);
1112 pragma Assert (Result = 0);
1113
1114 else
1115 S.State := True;
1116 end if;
1117
1118 Result := pthread_mutex_unlock (S.L'Access);
1119 pragma Assert (Result = 0);
1120
1121 SSL.Abort_Undefer.all;
1122 end Set_True;
1123
1124 ------------------------
1125 -- Suspend_Until_True --
1126 ------------------------
1127
1128 procedure Suspend_Until_True (S : in out Suspension_Object) is
1129 Result : Interfaces.C.int;
1130
1131 begin
1132 SSL.Abort_Defer.all;
1133
1134 Result := pthread_mutex_lock (S.L'Access);
1135 pragma Assert (Result = 0);
1136
1137 if S.Waiting then
1138
1139 -- Program_Error must be raised upon calling Suspend_Until_True
1140 -- if another task is already waiting on that suspension object
1141 -- (RM D.10(10)).
1142
1143 Result := pthread_mutex_unlock (S.L'Access);
1144 pragma Assert (Result = 0);
1145
1146 SSL.Abort_Undefer.all;
1147
1148 raise Program_Error;
1149
1150 else
1151 -- Suspend the task if the state is False. Otherwise, the task
1152 -- continues its execution, and the state of the suspension object
1153 -- is set to False (ARM D.10 par. 9).
1154
1155 if S.State then
1156 S.State := False;
1157 else
1158 S.Waiting := True;
1159
1160 loop
1161 -- Loop in case pthread_cond_wait returns earlier than expected
1162 -- (e.g. in case of EINTR caused by a signal).
1163
1164 Result := pthread_cond_wait (S.CV'Access, S.L'Access);
1165 pragma Assert (Result = 0 or else Result = EINTR);
1166
1167 exit when not S.Waiting;
1168 end loop;
1169 end if;
1170
1171 Result := pthread_mutex_unlock (S.L'Access);
1172 pragma Assert (Result = 0);
1173
1174 SSL.Abort_Undefer.all;
1175 end if;
1176 end Suspend_Until_True;
1177
1178 ----------------
1179 -- Check_Exit --
1180 ----------------
1181
1182 -- Dummy version
1183
1184 function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
1185 pragma Unreferenced (Self_ID);
1186 begin
1187 return True;
1188 end Check_Exit;
1189
1190 --------------------
1191 -- Check_No_Locks --
1192 --------------------
1193
1194 function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
1195 pragma Unreferenced (Self_ID);
1196 begin
1197 return True;
1198 end Check_No_Locks;
1199
1200 ----------------------
1201 -- Environment_Task --
1202 ----------------------
1203
1204 function Environment_Task return Task_Id is
1205 begin
1206 return Environment_Task_Id;
1207 end Environment_Task;
1208
1209 --------------
1210 -- Lock_RTS --
1211 --------------
1212
1213 procedure Lock_RTS is
1214 begin
1215 Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
1216 end Lock_RTS;
1217
1218 ----------------
1219 -- Unlock_RTS --
1220 ----------------
1221
1222 procedure Unlock_RTS is
1223 begin
1224 Unlock (Single_RTS_Lock'Access, Global_Lock => True);
1225 end Unlock_RTS;
1226
1227 ------------------
1228 -- Suspend_Task --
1229 ------------------
1230
1231 function Suspend_Task
1232 (T : ST.Task_Id;
1233 Thread_Self : Thread_Id) return Boolean
1234 is
1235 pragma Unreferenced (T, Thread_Self);
1236 begin
1237 return False;
1238 end Suspend_Task;
1239
1240 -----------------
1241 -- Resume_Task --
1242 -----------------
1243
1244 function Resume_Task
1245 (T : ST.Task_Id;
1246 Thread_Self : Thread_Id) return Boolean
1247 is
1248 pragma Unreferenced (T, Thread_Self);
1249 begin
1250 return False;
1251 end Resume_Task;
1252
1253 --------------------
1254 -- Stop_All_Tasks --
1255 --------------------
1256
1257 procedure Stop_All_Tasks is
1258 begin
1259 null;
1260 end Stop_All_Tasks;
1261
1262 ---------------
1263 -- Stop_Task --
1264 ---------------
1265
1266 function Stop_Task (T : ST.Task_Id) return Boolean is
1267 pragma Unreferenced (T);
1268 begin
1269 return False;
1270 end Stop_Task;
1271
1272 -------------------
1273 -- Continue_Task --
1274 -------------------
1275
1276 function Continue_Task (T : ST.Task_Id) return Boolean is
1277 pragma Unreferenced (T);
1278 begin
1279 return False;
1280 end Continue_Task;
1281
1282 ----------------
1283 -- Initialize --
1284 ----------------
1285
1286 procedure Initialize (Environment_Task : Task_Id) is
1287 act : aliased struct_sigaction;
1288 old_act : aliased struct_sigaction;
1289 Tmp_Set : aliased sigset_t;
1290 Result : Interfaces.C.int;
1291
1292 function State
1293 (Int : System.Interrupt_Management.Interrupt_ID) return Character;
1294 pragma Import (C, State, "__gnat_get_interrupt_state");
1295 -- Get interrupt state. Defined in a-init.c
1296 -- The input argument is the interrupt number,
1297 -- and the result is one of the following:
1298
1299 Default : constant Character := 's';
1300 -- 'n' this interrupt not set by any Interrupt_State pragma
1301 -- 'u' Interrupt_State pragma set state to User
1302 -- 'r' Interrupt_State pragma set state to Runtime
1303 -- 's' Interrupt_State pragma set state to System (use "default"
1304 -- system handler)
1305
1306 begin
1307 Environment_Task_Id := Environment_Task;
1308
1309 Interrupt_Management.Initialize;
1310
1311 -- Prepare the set of signals that should unblocked in all tasks
1312
1313 Result := sigemptyset (Unblocked_Signal_Mask'Access);
1314 pragma Assert (Result = 0);
1315
1316 for J in Interrupt_Management.Interrupt_ID loop
1317 if System.Interrupt_Management.Keep_Unmasked (J) then
1318 Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
1319 pragma Assert (Result = 0);
1320 end if;
1321 end loop;
1322
1323 -- Initialize the lock used to synchronize chain of all ATCBs
1324
1325 Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1326
1327 Specific.Initialize (Environment_Task);
1328
1329 if Use_Alternate_Stack then
1330 Environment_Task.Common.Task_Alternate_Stack :=
1331 Alternate_Stack'Address;
1332 end if;
1333
1334 -- Make environment task known here because it doesn't go through
1335 -- Activate_Tasks, which does it for all other tasks.
1336
1337 Known_Tasks (Known_Tasks'First) := Environment_Task;
1338 Environment_Task.Known_Tasks_Index := Known_Tasks'First;
1339
1340 Enter_Task (Environment_Task);
1341
1342 if State
1343 (System.Interrupt_Management.Abort_Task_Interrupt) /= Default
1344 then
1345 act.sa_flags := 0;
1346 act.sa_handler := Abort_Handler'Address;
1347
1348 Result := sigemptyset (Tmp_Set'Access);
1349 pragma Assert (Result = 0);
1350 act.sa_mask := Tmp_Set;
1351
1352 Result :=
1353 sigaction
1354 (Signal (System.Interrupt_Management.Abort_Task_Interrupt),
1355 act'Unchecked_Access,
1356 old_act'Unchecked_Access);
1357 pragma Assert (Result = 0);
1358 Abort_Handler_Installed := True;
1359 end if;
1360 end Initialize;
1361
1362 -----------------------
1363 -- Set_Task_Affinity --
1364 -----------------------
1365
1366 procedure Set_Task_Affinity (T : ST.Task_Id) is
1367 pragma Unreferenced (T);
1368
1369 begin
1370 -- Setting task affinity is not supported by the underlying system
1371
1372 null;
1373 end Set_Task_Affinity;
1374
1375 end System.Task_Primitives.Operations;