OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [s-taprop-linux.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS               --
4
--                                                                          --
5
--     S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S    --
6
--                                                                          --
7
--                                  B o d y                                 --
8
--                                                                          --
9
--         Copyright (C) 1992-2011, 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 GNU/Linux (GNU/LinuxThreads) version of this package
33
 
34
--  This package contains all the GNULL primitives that interface directly with
35
--  the underlying OS.
36
 
37
pragma 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
 
41
with Interfaces.C;
42
 
43
with System.Task_Info;
44
with System.Tasking.Debug;
45
with System.Interrupt_Management;
46
with System.OS_Primitives;
47
with System.Stack_Checking.Operations;
48
with System.Multiprocessors;
49
 
50
with System.Soft_Links;
51
--  We use System.Soft_Links instead of System.Tasking.Initialization
52
--  because the later is a higher level package that we shouldn't depend on.
53
--  For example when using the restricted run time, it is replaced by
54
--  System.Tasking.Restricted.Stages.
55
 
56
package body System.Task_Primitives.Operations is
57
 
58
   package SSL renames System.Soft_Links;
59
   package SC renames System.Stack_Checking.Operations;
60
 
61
   use System.Tasking.Debug;
62
   use System.Tasking;
63
   use Interfaces.C;
64
   use System.OS_Interface;
65
   use System.Parameters;
66
   use System.OS_Primitives;
67
   use System.Task_Info;
68
 
69
   ----------------
70
   -- Local Data --
71
   ----------------
72
 
73
   --  The followings are logically constants, but need to be initialized
74
   --  at run time.
75
 
76
   Single_RTS_Lock : aliased RTS_Lock;
77
   --  This is a lock to allow only one thread of control in the RTS at
78
   --  a time; it is used to execute in mutual exclusion from all other tasks.
79
   --  Used mainly in Single_Lock mode, but also to protect All_Tasks_List
80
 
81
   Environment_Task_Id : Task_Id;
82
   --  A variable to hold Task_Id for the environment task
83
 
84
   Unblocked_Signal_Mask : aliased sigset_t;
85
   --  The set of signals that should be unblocked in all tasks
86
 
87
   --  The followings are internal configuration constants needed
88
 
89
   Next_Serial_Number : Task_Serial_Number := 100;
90
   --  We start at 100 (reserve some special values for using in error checks)
91
 
92
   Time_Slice_Val : Integer;
93
   pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
94
 
95
   Dispatching_Policy : Character;
96
   pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
97
 
98
   Locking_Policy : Character;
99
   pragma Import (C, Locking_Policy, "__gl_locking_policy");
100
 
101
   Foreign_Task_Elaborated : aliased Boolean := True;
102
   --  Used to identified fake tasks (i.e., non-Ada Threads)
103
 
104
   Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0;
105
   --  Whether to use an alternate signal stack for stack overflows
106
 
107
   Abort_Handler_Installed : Boolean := False;
108
   --  True if a handler for the abort signal is installed
109
 
110
   Null_Thread_Id : constant pthread_t := pthread_t'Last;
111
   --  Constant to indicate that the thread identifier has not yet been
112
   --  initialized.
113
 
114
   --------------------
115
   -- Local Packages --
116
   --------------------
117
 
118
   package Specific is
119
 
120
      procedure Initialize (Environment_Task : Task_Id);
121
      pragma Inline (Initialize);
122
      --  Initialize various data needed by this package
123
 
124
      function Is_Valid_Task return Boolean;
125
      pragma Inline (Is_Valid_Task);
126
      --  Does executing thread have a TCB?
127
 
128
      procedure Set (Self_Id : Task_Id);
129
      pragma Inline (Set);
130
      --  Set the self id for the current task
131
 
132
      function Self return Task_Id;
133
      pragma Inline (Self);
134
      --  Return a pointer to the Ada Task Control Block of the calling task
135
 
136
   end Specific;
137
 
138
   package body Specific is separate;
139
   --  The body of this package is target specific
140
 
141
   ----------------------------------
142
   -- ATCB allocation/deallocation --
143
   ----------------------------------
144
 
145
   package body ATCB_Allocation is separate;
146
   --  The body of this package is shared across several targets
147
 
148
   ---------------------------------
149
   -- Support for foreign threads --
150
   ---------------------------------
151
 
152
   function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
153
   --  Allocate and Initialize a new ATCB for the current Thread
154
 
155
   function Register_Foreign_Thread
156
     (Thread : Thread_Id) return Task_Id is separate;
157
 
158
   -----------------------
159
   -- Local Subprograms --
160
   -----------------------
161
 
162
   procedure Abort_Handler (signo : Signal);
163
 
164
   -------------------
165
   -- Abort_Handler --
166
   -------------------
167
 
168
   procedure Abort_Handler (signo : Signal) is
169
      pragma Unreferenced (signo);
170
 
171
      Self_Id : constant Task_Id := Self;
172
      Result  : Interfaces.C.int;
173
      Old_Set : aliased sigset_t;
174
 
175
   begin
176
      --  It's not safe to raise an exception when using GCC ZCX mechanism.
177
      --  Note that we still need to install a signal handler, since in some
178
      --  cases (e.g. shutdown of the Server_Task in System.Interrupts) we
179
      --  need to send the Abort signal to a task.
180
 
181
      if ZCX_By_Default then
182
         return;
183
      end if;
184
 
185
      if Self_Id.Deferral_Level = 0
186
        and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level
187
        and then not Self_Id.Aborting
188
      then
189
         Self_Id.Aborting := True;
190
 
191
         --  Make sure signals used for RTS internal purpose are unmasked
192
 
193
         Result :=
194
           pthread_sigmask
195
             (SIG_UNBLOCK,
196
              Unblocked_Signal_Mask'Access,
197
              Old_Set'Access);
198
         pragma Assert (Result = 0);
199
 
200
         raise Standard'Abort_Signal;
201
      end if;
202
   end Abort_Handler;
203
 
204
   --------------
205
   -- Lock_RTS --
206
   --------------
207
 
208
   procedure Lock_RTS is
209
   begin
210
      Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
211
   end Lock_RTS;
212
 
213
   ----------------
214
   -- Unlock_RTS --
215
   ----------------
216
 
217
   procedure Unlock_RTS is
218
   begin
219
      Unlock (Single_RTS_Lock'Access, Global_Lock => True);
220
   end Unlock_RTS;
221
 
222
   -----------------
223
   -- Stack_Guard --
224
   -----------------
225
 
226
   --  The underlying thread system extends the memory (up to 2MB) when needed
227
 
228
   procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
229
      pragma Unreferenced (T);
230
      pragma Unreferenced (On);
231
   begin
232
      null;
233
   end Stack_Guard;
234
 
235
   --------------------
236
   -- Get_Thread_Id  --
237
   --------------------
238
 
239
   function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
240
   begin
241
      return T.Common.LL.Thread;
242
   end Get_Thread_Id;
243
 
244
   ----------
245
   -- Self --
246
   ----------
247
 
248
   function Self return Task_Id renames Specific.Self;
249
 
250
   ---------------------
251
   -- Initialize_Lock --
252
   ---------------------
253
 
254
   --  Note: mutexes and cond_variables needed per-task basis are initialized
255
   --  in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
256
   --  as RTS_Lock, Memory_Lock...) used in RTS is initialized before any
257
   --  status change of RTS. Therefore raising Storage_Error in the following
258
   --  routines should be able to be handled safely.
259
 
260
   procedure Initialize_Lock
261
     (Prio : System.Any_Priority;
262
      L    : not null access Lock)
263
   is
264
      pragma Unreferenced (Prio);
265
 
266
   begin
267
      if Locking_Policy = 'R' then
268
         declare
269
            RWlock_Attr : aliased pthread_rwlockattr_t;
270
            Result      : Interfaces.C.int;
271
 
272
         begin
273
            --  Set the rwlock to prefer writer to avoid writers starvation
274
 
275
            Result := pthread_rwlockattr_init (RWlock_Attr'Access);
276
            pragma Assert (Result = 0);
277
 
278
            Result := pthread_rwlockattr_setkind_np
279
              (RWlock_Attr'Access,
280
               PTHREAD_RWLOCK_PREFER_WRITER_NONRECURSIVE_NP);
281
            pragma Assert (Result = 0);
282
 
283
            Result := pthread_rwlock_init (L.RW'Access, RWlock_Attr'Access);
284
 
285
            pragma Assert (Result = 0 or else Result = ENOMEM);
286
 
287
            if Result = ENOMEM then
288
               raise Storage_Error with "Failed to allocate a lock";
289
            end if;
290
         end;
291
 
292
      else
293
         declare
294
            Result : Interfaces.C.int;
295
 
296
         begin
297
            Result := pthread_mutex_init (L.WO'Access, null);
298
 
299
            pragma Assert (Result = 0 or else Result = ENOMEM);
300
 
301
            if Result = ENOMEM then
302
               raise Storage_Error with "Failed to allocate a lock";
303
            end if;
304
         end;
305
      end if;
306
   end Initialize_Lock;
307
 
308
   procedure Initialize_Lock
309
     (L     : not null access RTS_Lock;
310
      Level : Lock_Level)
311
   is
312
      pragma Unreferenced (Level);
313
 
314
      Result : Interfaces.C.int;
315
 
316
   begin
317
      Result := pthread_mutex_init (L, null);
318
 
319
      pragma Assert (Result = 0 or else Result = ENOMEM);
320
 
321
      if Result = ENOMEM then
322
         raise Storage_Error;
323
      end if;
324
   end Initialize_Lock;
325
 
326
   -------------------
327
   -- Finalize_Lock --
328
   -------------------
329
 
330
   procedure Finalize_Lock (L : not null access Lock) is
331
      Result : Interfaces.C.int;
332
   begin
333
      if Locking_Policy = 'R' then
334
         Result := pthread_rwlock_destroy (L.RW'Access);
335
      else
336
         Result := pthread_mutex_destroy (L.WO'Access);
337
      end if;
338
      pragma Assert (Result = 0);
339
   end Finalize_Lock;
340
 
341
   procedure Finalize_Lock (L : not null access RTS_Lock) is
342
      Result : Interfaces.C.int;
343
   begin
344
      Result := pthread_mutex_destroy (L);
345
      pragma Assert (Result = 0);
346
   end Finalize_Lock;
347
 
348
   ----------------
349
   -- Write_Lock --
350
   ----------------
351
 
352
   procedure Write_Lock
353
     (L                 : not null access Lock;
354
      Ceiling_Violation : out Boolean)
355
   is
356
      Result : Interfaces.C.int;
357
   begin
358
      if Locking_Policy = 'R' then
359
         Result := pthread_rwlock_wrlock (L.RW'Access);
360
      else
361
         Result := pthread_mutex_lock (L.WO'Access);
362
      end if;
363
 
364
      Ceiling_Violation := Result = EINVAL;
365
 
366
      --  Assume the cause of EINVAL is a priority ceiling violation
367
 
368
      pragma Assert (Result = 0 or else Result = EINVAL);
369
   end Write_Lock;
370
 
371
   procedure Write_Lock
372
     (L           : not null access RTS_Lock;
373
      Global_Lock : Boolean := False)
374
   is
375
      Result : Interfaces.C.int;
376
   begin
377
      if not Single_Lock or else Global_Lock then
378
         Result := pthread_mutex_lock (L);
379
         pragma Assert (Result = 0);
380
      end if;
381
   end Write_Lock;
382
 
383
   procedure Write_Lock (T : Task_Id) is
384
      Result : Interfaces.C.int;
385
   begin
386
      if not Single_Lock then
387
         Result := pthread_mutex_lock (T.Common.LL.L'Access);
388
         pragma Assert (Result = 0);
389
      end if;
390
   end Write_Lock;
391
 
392
   ---------------
393
   -- Read_Lock --
394
   ---------------
395
 
396
   procedure Read_Lock
397
     (L                 : not null access Lock;
398
      Ceiling_Violation : out Boolean)
399
   is
400
      Result : Interfaces.C.int;
401
   begin
402
      if Locking_Policy = 'R' then
403
         Result := pthread_rwlock_rdlock (L.RW'Access);
404
      else
405
         Result := pthread_mutex_lock (L.WO'Access);
406
      end if;
407
 
408
      Ceiling_Violation := Result = EINVAL;
409
 
410
      --  Assume the cause of EINVAL is a priority ceiling violation
411
 
412
      pragma Assert (Result = 0 or else Result = EINVAL);
413
   end Read_Lock;
414
 
415
   ------------
416
   -- Unlock --
417
   ------------
418
 
419
   procedure Unlock (L : not null access Lock) is
420
      Result : Interfaces.C.int;
421
   begin
422
      if Locking_Policy = 'R' then
423
         Result := pthread_rwlock_unlock (L.RW'Access);
424
      else
425
         Result := pthread_mutex_unlock (L.WO'Access);
426
      end if;
427
      pragma Assert (Result = 0);
428
   end Unlock;
429
 
430
   procedure Unlock
431
     (L           : not null access RTS_Lock;
432
      Global_Lock : Boolean := False)
433
   is
434
      Result : Interfaces.C.int;
435
   begin
436
      if not Single_Lock or else Global_Lock then
437
         Result := pthread_mutex_unlock (L);
438
         pragma Assert (Result = 0);
439
      end if;
440
   end Unlock;
441
 
442
   procedure Unlock (T : Task_Id) is
443
      Result : Interfaces.C.int;
444
   begin
445
      if not Single_Lock then
446
         Result := pthread_mutex_unlock (T.Common.LL.L'Access);
447
         pragma Assert (Result = 0);
448
      end if;
449
   end Unlock;
450
 
451
   -----------------
452
   -- Set_Ceiling --
453
   -----------------
454
 
455
   --  Dynamic priority ceilings are not supported by the underlying system
456
 
457
   procedure Set_Ceiling
458
     (L    : not null access Lock;
459
      Prio : System.Any_Priority)
460
   is
461
      pragma Unreferenced (L, Prio);
462
   begin
463
      null;
464
   end Set_Ceiling;
465
 
466
   -----------
467
   -- Sleep --
468
   -----------
469
 
470
   procedure Sleep
471
     (Self_ID  : Task_Id;
472
      Reason   : System.Tasking.Task_States)
473
   is
474
      pragma Unreferenced (Reason);
475
 
476
      Result : Interfaces.C.int;
477
 
478
   begin
479
      pragma Assert (Self_ID = Self);
480
 
481
      Result :=
482
        pthread_cond_wait
483
          (cond  => Self_ID.Common.LL.CV'Access,
484
           mutex => (if Single_Lock
485
                     then Single_RTS_Lock'Access
486
                     else Self_ID.Common.LL.L'Access));
487
 
488
      --  EINTR is not considered a failure
489
 
490
      pragma Assert (Result = 0 or else Result = EINTR);
491
   end Sleep;
492
 
493
   -----------------
494
   -- Timed_Sleep --
495
   -----------------
496
 
497
   --  This is for use within the run-time system, so abort is
498
   --  assumed to be already deferred, and the caller should be
499
   --  holding its own ATCB lock.
500
 
501
   procedure Timed_Sleep
502
     (Self_ID  : Task_Id;
503
      Time     : Duration;
504
      Mode     : ST.Delay_Modes;
505
      Reason   : System.Tasking.Task_States;
506
      Timedout : out Boolean;
507
      Yielded  : out Boolean)
508
   is
509
      pragma Unreferenced (Reason);
510
 
511
      Base_Time  : constant Duration := Monotonic_Clock;
512
      Check_Time : Duration := Base_Time;
513
      Abs_Time   : Duration;
514
      Request    : aliased timespec;
515
      Result     : Interfaces.C.int;
516
 
517
   begin
518
      Timedout := True;
519
      Yielded := False;
520
 
521
      Abs_Time :=
522
        (if Mode = Relative
523
         then Duration'Min (Time, Max_Sensible_Delay) + Check_Time
524
         else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
525
 
526
      if Abs_Time > Check_Time then
527
         Request := To_Timespec (Abs_Time);
528
 
529
         loop
530
            exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
531
 
532
            Result :=
533
              pthread_cond_timedwait
534
                (cond    => Self_ID.Common.LL.CV'Access,
535
                 mutex   => (if Single_Lock
536
                             then Single_RTS_Lock'Access
537
                             else Self_ID.Common.LL.L'Access),
538
                 abstime => Request'Access);
539
 
540
            Check_Time := Monotonic_Clock;
541
            exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
542
 
543
            if Result = 0 or else Result = EINTR then
544
 
545
               --  Somebody may have called Wakeup for us
546
 
547
               Timedout := False;
548
               exit;
549
            end if;
550
 
551
            pragma Assert (Result = ETIMEDOUT);
552
         end loop;
553
      end if;
554
   end Timed_Sleep;
555
 
556
   -----------------
557
   -- Timed_Delay --
558
   -----------------
559
 
560
   --  This is for use in implementing delay statements, so we assume the
561
   --  caller is abort-deferred but is holding no locks.
562
 
563
   procedure Timed_Delay
564
     (Self_ID : Task_Id;
565
      Time    : Duration;
566
      Mode    : ST.Delay_Modes)
567
   is
568
      Base_Time  : constant Duration := Monotonic_Clock;
569
      Check_Time : Duration := Base_Time;
570
      Abs_Time   : Duration;
571
      Request    : aliased timespec;
572
 
573
      Result : Interfaces.C.int;
574
      pragma Warnings (Off, Result);
575
 
576
   begin
577
      if Single_Lock then
578
         Lock_RTS;
579
      end if;
580
 
581
      Write_Lock (Self_ID);
582
 
583
      Abs_Time :=
584
        (if Mode = Relative
585
         then Time + Check_Time
586
         else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
587
 
588
      if Abs_Time > Check_Time then
589
         Request := To_Timespec (Abs_Time);
590
         Self_ID.Common.State := Delay_Sleep;
591
 
592
         loop
593
            exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
594
 
595
            Result :=
596
              pthread_cond_timedwait
597
                (cond    => Self_ID.Common.LL.CV'Access,
598
                 mutex   => (if Single_Lock
599
                             then Single_RTS_Lock'Access
600
                             else Self_ID.Common.LL.L'Access),
601
                 abstime => Request'Access);
602
 
603
            Check_Time := Monotonic_Clock;
604
            exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
605
 
606
            pragma Assert (Result = 0 or else
607
              Result = ETIMEDOUT or else
608
              Result = EINTR);
609
         end loop;
610
 
611
         Self_ID.Common.State := Runnable;
612
      end if;
613
 
614
      Unlock (Self_ID);
615
 
616
      if Single_Lock then
617
         Unlock_RTS;
618
      end if;
619
 
620
      Result := sched_yield;
621
   end Timed_Delay;
622
 
623
   ---------------------
624
   -- Monotonic_Clock --
625
   ---------------------
626
 
627
   function Monotonic_Clock return Duration is
628
      use Interfaces;
629
 
630
      type timeval is array (1 .. 2) of C.long;
631
 
632
      procedure timeval_to_duration
633
        (T    : not null access timeval;
634
         sec  : not null access C.long;
635
         usec : not null access C.long);
636
      pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration");
637
 
638
      Micro  : constant := 10**6;
639
      sec    : aliased C.long;
640
      usec   : aliased C.long;
641
      TV     : aliased timeval;
642
      Result : int;
643
 
644
      function gettimeofday
645
        (Tv : access timeval;
646
         Tz : System.Address := System.Null_Address) return int;
647
      pragma Import (C, gettimeofday, "gettimeofday");
648
 
649
   begin
650
      Result := gettimeofday (TV'Access, System.Null_Address);
651
      pragma Assert (Result = 0);
652
      timeval_to_duration (TV'Access, sec'Access, usec'Access);
653
      return Duration (sec) + Duration (usec) / Micro;
654
   end Monotonic_Clock;
655
 
656
   -------------------
657
   -- RT_Resolution --
658
   -------------------
659
 
660
   function RT_Resolution return Duration is
661
   begin
662
      return 10#1.0#E-6;
663
   end RT_Resolution;
664
 
665
   ------------
666
   -- Wakeup --
667
   ------------
668
 
669
   procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
670
      pragma Unreferenced (Reason);
671
      Result : Interfaces.C.int;
672
   begin
673
      Result := pthread_cond_signal (T.Common.LL.CV'Access);
674
      pragma Assert (Result = 0);
675
   end Wakeup;
676
 
677
   -----------
678
   -- Yield --
679
   -----------
680
 
681
   procedure Yield (Do_Yield : Boolean := True) is
682
      Result : Interfaces.C.int;
683
      pragma Unreferenced (Result);
684
   begin
685
      if Do_Yield then
686
         Result := sched_yield;
687
      end if;
688
   end Yield;
689
 
690
   ------------------
691
   -- Set_Priority --
692
   ------------------
693
 
694
   procedure Set_Priority
695
     (T                   : Task_Id;
696
      Prio                : System.Any_Priority;
697
      Loss_Of_Inheritance : Boolean := False)
698
   is
699
      pragma Unreferenced (Loss_Of_Inheritance);
700
 
701
      Result : Interfaces.C.int;
702
      Param  : aliased struct_sched_param;
703
 
704
      function Get_Policy (Prio : System.Any_Priority) return Character;
705
      pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
706
      --  Get priority specific dispatching policy
707
 
708
      Priority_Specific_Policy : constant Character := Get_Policy (Prio);
709
      --  Upper case first character of the policy name corresponding to the
710
      --  task as set by a Priority_Specific_Dispatching pragma.
711
 
712
   begin
713
      T.Common.Current_Priority := Prio;
714
 
715
      --  Priorities are 1 .. 99 on GNU/Linux, so we map 0 .. 98 to 1 .. 99
716
 
717
      Param.sched_priority := Interfaces.C.int (Prio) + 1;
718
 
719
      if Dispatching_Policy = 'R'
720
        or else Priority_Specific_Policy = 'R'
721
        or else Time_Slice_Val > 0
722
      then
723
         Result :=
724
           pthread_setschedparam
725
             (T.Common.LL.Thread, SCHED_RR, Param'Access);
726
 
727
      elsif Dispatching_Policy = 'F'
728
        or else Priority_Specific_Policy = 'F'
729
        or else Time_Slice_Val = 0
730
      then
731
         Result :=
732
           pthread_setschedparam
733
             (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
734
 
735
      else
736
         Param.sched_priority := 0;
737
         Result :=
738
           pthread_setschedparam
739
             (T.Common.LL.Thread,
740
              SCHED_OTHER, Param'Access);
741
      end if;
742
 
743
      pragma Assert (Result = 0 or else Result = EPERM);
744
   end Set_Priority;
745
 
746
   ------------------
747
   -- Get_Priority --
748
   ------------------
749
 
750
   function Get_Priority (T : Task_Id) return System.Any_Priority is
751
   begin
752
      return T.Common.Current_Priority;
753
   end Get_Priority;
754
 
755
   ----------------
756
   -- Enter_Task --
757
   ----------------
758
 
759
   procedure Enter_Task (Self_ID : Task_Id) is
760
   begin
761
      if Self_ID.Common.Task_Info /= null
762
        and then Self_ID.Common.Task_Info.CPU_Affinity = No_CPU
763
      then
764
         raise Invalid_CPU_Number;
765
      end if;
766
 
767
      Self_ID.Common.LL.Thread := pthread_self;
768
      Self_ID.Common.LL.LWP := lwp_self;
769
 
770
      Specific.Set (Self_ID);
771
 
772
      if Use_Alternate_Stack
773
        and then Self_ID.Common.Task_Alternate_Stack /= Null_Address
774
      then
775
         declare
776
            Stack  : aliased stack_t;
777
            Result : Interfaces.C.int;
778
         begin
779
            Stack.ss_sp    := Self_ID.Common.Task_Alternate_Stack;
780
            Stack.ss_size  := Alternate_Stack_Size;
781
            Stack.ss_flags := 0;
782
            Result := sigaltstack (Stack'Access, null);
783
            pragma Assert (Result = 0);
784
         end;
785
      end if;
786
   end Enter_Task;
787
 
788
   -------------------
789
   -- Is_Valid_Task --
790
   -------------------
791
 
792
   function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
793
 
794
   -----------------------------
795
   -- Register_Foreign_Thread --
796
   -----------------------------
797
 
798
   function Register_Foreign_Thread return Task_Id is
799
   begin
800
      if Is_Valid_Task then
801
         return Self;
802
      else
803
         return Register_Foreign_Thread (pthread_self);
804
      end if;
805
   end Register_Foreign_Thread;
806
 
807
   --------------------
808
   -- Initialize_TCB --
809
   --------------------
810
 
811
   procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
812
      Cond_Attr : aliased pthread_condattr_t;
813
      Result    : Interfaces.C.int;
814
 
815
   begin
816
      --  Give the task a unique serial number
817
 
818
      Self_ID.Serial_Number := Next_Serial_Number;
819
      Next_Serial_Number := Next_Serial_Number + 1;
820
      pragma Assert (Next_Serial_Number /= 0);
821
 
822
      Self_ID.Common.LL.Thread := Null_Thread_Id;
823
 
824
      if not Single_Lock then
825
         Result :=
826
           pthread_mutex_init (Self_ID.Common.LL.L'Access, null);
827
         pragma Assert (Result = 0 or else Result = ENOMEM);
828
 
829
         if Result /= 0 then
830
            Succeeded := False;
831
            return;
832
         end if;
833
      end if;
834
 
835
      Result := pthread_condattr_init (Cond_Attr'Access);
836
      pragma Assert (Result = 0);
837
 
838
      Result :=
839
        pthread_cond_init (Self_ID.Common.LL.CV'Access, Cond_Attr'Access);
840
      pragma Assert (Result = 0 or else Result = ENOMEM);
841
 
842
      if Result = 0 then
843
         Succeeded := True;
844
      else
845
         if not Single_Lock then
846
            Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
847
            pragma Assert (Result = 0);
848
         end if;
849
 
850
         Succeeded := False;
851
      end if;
852
   end Initialize_TCB;
853
 
854
   -----------------
855
   -- Create_Task --
856
   -----------------
857
 
858
   procedure Create_Task
859
     (T          : Task_Id;
860
      Wrapper    : System.Address;
861
      Stack_Size : System.Parameters.Size_Type;
862
      Priority   : System.Any_Priority;
863
      Succeeded  : out Boolean)
864
   is
865
      Attributes          : aliased pthread_attr_t;
866
      Adjusted_Stack_Size : Interfaces.C.size_t;
867
      Result              : Interfaces.C.int;
868
 
869
      use type System.Multiprocessors.CPU_Range;
870
 
871
   begin
872
      --  Check whether both Dispatching_Domain and CPU are specified for
873
      --  the task, and the CPU value is not contained within the range of
874
      --  processors for the domain.
875
 
876
      if T.Common.Domain /= null
877
        and then T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU
878
        and then
879
          (T.Common.Base_CPU not in T.Common.Domain'Range
880
            or else not T.Common.Domain (T.Common.Base_CPU))
881
      then
882
         Succeeded := False;
883
         return;
884
      end if;
885
 
886
      Adjusted_Stack_Size :=
887
         Interfaces.C.size_t (Stack_Size + Alternate_Stack_Size);
888
 
889
      Result := pthread_attr_init (Attributes'Access);
890
      pragma Assert (Result = 0 or else Result = ENOMEM);
891
 
892
      if Result /= 0 then
893
         Succeeded := False;
894
         return;
895
      end if;
896
 
897
      Result :=
898
        pthread_attr_setstacksize (Attributes'Access, Adjusted_Stack_Size);
899
      pragma Assert (Result = 0);
900
 
901
      Result :=
902
        pthread_attr_setdetachstate
903
          (Attributes'Access, PTHREAD_CREATE_DETACHED);
904
      pragma Assert (Result = 0);
905
 
906
      --  Set the required attributes for the creation of the thread
907
 
908
      --  Note: Previously, we called pthread_setaffinity_np (after thread
909
      --  creation but before thread activation) to set the affinity but it was
910
      --  not behaving as expected. Setting the required attributes for the
911
      --  creation of the thread works correctly and it is more appropriate.
912
 
913
      --  Do nothing if required support not provided by the operating system
914
 
915
      if pthread_attr_setaffinity_np'Address = System.Null_Address then
916
         null;
917
 
918
      --  Support is available
919
 
920
      elsif T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU then
921
         declare
922
            CPUs    : constant size_t :=
923
                        Interfaces.C.size_t
924
                          (System.Multiprocessors.Number_Of_CPUs);
925
            CPU_Set : constant cpu_set_t_ptr := CPU_ALLOC (CPUs);
926
            Size    : constant size_t := CPU_ALLOC_SIZE (CPUs);
927
 
928
         begin
929
            CPU_ZERO (Size, CPU_Set);
930
            System.OS_Interface.CPU_SET
931
              (int (T.Common.Base_CPU), Size, CPU_Set);
932
            Result :=
933
              pthread_attr_setaffinity_np (Attributes'Access, Size, CPU_Set);
934
            pragma Assert (Result = 0);
935
 
936
            CPU_FREE (CPU_Set);
937
         end;
938
 
939
      --  Handle Task_Info
940
 
941
      elsif T.Common.Task_Info /= null then
942
         Result :=
943
           pthread_attr_setaffinity_np
944
             (Attributes'Access,
945
              CPU_SETSIZE / 8,
946
              T.Common.Task_Info.CPU_Affinity'Access);
947
         pragma Assert (Result = 0);
948
 
949
      --  Handle dispatching domains
950
 
951
      --  To avoid changing CPU affinities when not needed, we set the
952
      --  affinity only when assigning to a domain other than the default
953
      --  one, or when the default one has been modified.
954
 
955
      elsif T.Common.Domain /= null and then
956
        (T.Common.Domain /= ST.System_Domain
957
          or else T.Common.Domain.all /=
958
                    (Multiprocessors.CPU'First ..
959
                     Multiprocessors.Number_Of_CPUs => True))
960
      then
961
         declare
962
            CPUs    : constant size_t :=
963
                        Interfaces.C.size_t
964
                          (System.Multiprocessors.Number_Of_CPUs);
965
            CPU_Set : constant cpu_set_t_ptr := CPU_ALLOC (CPUs);
966
            Size    : constant size_t := CPU_ALLOC_SIZE (CPUs);
967
 
968
         begin
969
            CPU_ZERO (Size, CPU_Set);
970
 
971
            --  Set the affinity to all the processors belonging to the
972
            --  dispatching domain.
973
 
974
            for Proc in T.Common.Domain'Range loop
975
               if T.Common.Domain (Proc) then
976
                  System.OS_Interface.CPU_SET (int (Proc), Size, CPU_Set);
977
               end if;
978
            end loop;
979
 
980
            Result :=
981
              pthread_attr_setaffinity_np (Attributes'Access, Size, CPU_Set);
982
            pragma Assert (Result = 0);
983
 
984
            CPU_FREE (CPU_Set);
985
         end;
986
      end if;
987
 
988
      --  Since the initial signal mask of a thread is inherited from the
989
      --  creator, and the Environment task has all its signals masked, we
990
      --  do not need to manipulate caller's signal mask at this point.
991
      --  All tasks in RTS will have All_Tasks_Mask initially.
992
 
993
      --  Note: the use of Unrestricted_Access in the following call is needed
994
      --  because otherwise we have an error of getting a access-to-volatile
995
      --  value which points to a non-volatile object. But in this case it is
996
      --  safe to do this, since we know we have no problems with aliasing and
997
      --  Unrestricted_Access bypasses this check.
998
 
999
      Result :=
1000
        pthread_create
1001
          (T.Common.LL.Thread'Unrestricted_Access,
1002
           Attributes'Access,
1003
           Thread_Body_Access (Wrapper),
1004
           To_Address (T));
1005
 
1006
      pragma Assert
1007
        (Result = 0 or else Result = EAGAIN or else Result = ENOMEM);
1008
 
1009
      if Result /= 0 then
1010
         Succeeded := False;
1011
         Result := pthread_attr_destroy (Attributes'Access);
1012
         pragma Assert (Result = 0);
1013
         return;
1014
      end if;
1015
 
1016
      Succeeded := True;
1017
 
1018
      Result := pthread_attr_destroy (Attributes'Access);
1019
      pragma Assert (Result = 0);
1020
 
1021
      Set_Priority (T, Priority);
1022
   end Create_Task;
1023
 
1024
   ------------------
1025
   -- Finalize_TCB --
1026
   ------------------
1027
 
1028
   procedure Finalize_TCB (T : Task_Id) is
1029
      Result : Interfaces.C.int;
1030
 
1031
   begin
1032
      if not Single_Lock then
1033
         Result := pthread_mutex_destroy (T.Common.LL.L'Access);
1034
         pragma Assert (Result = 0);
1035
      end if;
1036
 
1037
      Result := pthread_cond_destroy (T.Common.LL.CV'Access);
1038
      pragma Assert (Result = 0);
1039
 
1040
      if T.Known_Tasks_Index /= -1 then
1041
         Known_Tasks (T.Known_Tasks_Index) := null;
1042
      end if;
1043
 
1044
      SC.Invalidate_Stack_Cache (T.Common.Compiler_Data.Pri_Stack_Info'Access);
1045
 
1046
      ATCB_Allocation.Free_ATCB (T);
1047
   end Finalize_TCB;
1048
 
1049
   ---------------
1050
   -- Exit_Task --
1051
   ---------------
1052
 
1053
   procedure Exit_Task is
1054
   begin
1055
      Specific.Set (null);
1056
   end Exit_Task;
1057
 
1058
   ----------------
1059
   -- Abort_Task --
1060
   ----------------
1061
 
1062
   procedure Abort_Task (T : Task_Id) is
1063
      Result : Interfaces.C.int;
1064
   begin
1065
      if Abort_Handler_Installed then
1066
         Result :=
1067
           pthread_kill
1068
             (T.Common.LL.Thread,
1069
              Signal (System.Interrupt_Management.Abort_Task_Interrupt));
1070
         pragma Assert (Result = 0);
1071
      end if;
1072
   end Abort_Task;
1073
 
1074
   ----------------
1075
   -- Initialize --
1076
   ----------------
1077
 
1078
   procedure Initialize (S : in out Suspension_Object) is
1079
      Result : Interfaces.C.int;
1080
 
1081
   begin
1082
      --  Initialize internal state (always to False (RM D.10(6)))
1083
 
1084
      S.State := False;
1085
      S.Waiting := False;
1086
 
1087
      --  Initialize internal mutex
1088
 
1089
      Result := pthread_mutex_init (S.L'Access, null);
1090
 
1091
      pragma Assert (Result = 0 or else Result = ENOMEM);
1092
 
1093
      if Result = ENOMEM then
1094
         raise Storage_Error;
1095
      end if;
1096
 
1097
      --  Initialize internal condition variable
1098
 
1099
      Result := pthread_cond_init (S.CV'Access, null);
1100
 
1101
      pragma Assert (Result = 0 or else Result = ENOMEM);
1102
 
1103
      if Result /= 0 then
1104
         Result := pthread_mutex_destroy (S.L'Access);
1105
         pragma Assert (Result = 0);
1106
 
1107
         if Result = ENOMEM then
1108
            raise Storage_Error;
1109
         end if;
1110
      end if;
1111
   end Initialize;
1112
 
1113
   --------------
1114
   -- Finalize --
1115
   --------------
1116
 
1117
   procedure Finalize (S : in out Suspension_Object) is
1118
      Result : Interfaces.C.int;
1119
 
1120
   begin
1121
      --  Destroy internal mutex
1122
 
1123
      Result := pthread_mutex_destroy (S.L'Access);
1124
      pragma Assert (Result = 0);
1125
 
1126
      --  Destroy internal condition variable
1127
 
1128
      Result := pthread_cond_destroy (S.CV'Access);
1129
      pragma Assert (Result = 0);
1130
   end Finalize;
1131
 
1132
   -------------------
1133
   -- Current_State --
1134
   -------------------
1135
 
1136
   function Current_State (S : Suspension_Object) return Boolean is
1137
   begin
1138
      --  We do not want to use lock on this read operation. State is marked
1139
      --  as Atomic so that we ensure that the value retrieved is correct.
1140
 
1141
      return S.State;
1142
   end Current_State;
1143
 
1144
   ---------------
1145
   -- Set_False --
1146
   ---------------
1147
 
1148
   procedure Set_False (S : in out Suspension_Object) is
1149
      Result : Interfaces.C.int;
1150
 
1151
   begin
1152
      SSL.Abort_Defer.all;
1153
 
1154
      Result := pthread_mutex_lock (S.L'Access);
1155
      pragma Assert (Result = 0);
1156
 
1157
      S.State := False;
1158
 
1159
      Result := pthread_mutex_unlock (S.L'Access);
1160
      pragma Assert (Result = 0);
1161
 
1162
      SSL.Abort_Undefer.all;
1163
   end Set_False;
1164
 
1165
   --------------
1166
   -- Set_True --
1167
   --------------
1168
 
1169
   procedure Set_True (S : in out Suspension_Object) is
1170
      Result : Interfaces.C.int;
1171
 
1172
   begin
1173
      SSL.Abort_Defer.all;
1174
 
1175
      Result := pthread_mutex_lock (S.L'Access);
1176
      pragma Assert (Result = 0);
1177
 
1178
      --  If there is already a task waiting on this suspension object then
1179
      --  we resume it, leaving the state of the suspension object to False,
1180
      --  as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
1181
      --  the state to True.
1182
 
1183
      if S.Waiting then
1184
         S.Waiting := False;
1185
         S.State := False;
1186
 
1187
         Result := pthread_cond_signal (S.CV'Access);
1188
         pragma Assert (Result = 0);
1189
 
1190
      else
1191
         S.State := True;
1192
      end if;
1193
 
1194
      Result := pthread_mutex_unlock (S.L'Access);
1195
      pragma Assert (Result = 0);
1196
 
1197
      SSL.Abort_Undefer.all;
1198
   end Set_True;
1199
 
1200
   ------------------------
1201
   -- Suspend_Until_True --
1202
   ------------------------
1203
 
1204
   procedure Suspend_Until_True (S : in out Suspension_Object) is
1205
      Result : Interfaces.C.int;
1206
 
1207
   begin
1208
      SSL.Abort_Defer.all;
1209
 
1210
      Result := pthread_mutex_lock (S.L'Access);
1211
      pragma Assert (Result = 0);
1212
 
1213
      if S.Waiting then
1214
 
1215
         --  Program_Error must be raised upon calling Suspend_Until_True
1216
         --  if another task is already waiting on that suspension object
1217
         --  (RM D.10(10)).
1218
 
1219
         Result := pthread_mutex_unlock (S.L'Access);
1220
         pragma Assert (Result = 0);
1221
 
1222
         SSL.Abort_Undefer.all;
1223
 
1224
         raise Program_Error;
1225
 
1226
      else
1227
         --  Suspend the task if the state is False. Otherwise, the task
1228
         --  continues its execution, and the state of the suspension object
1229
         --  is set to False (ARM D.10 par. 9).
1230
 
1231
         if S.State then
1232
            S.State := False;
1233
         else
1234
            S.Waiting := True;
1235
 
1236
            loop
1237
               --  Loop in case pthread_cond_wait returns earlier than expected
1238
               --  (e.g. in case of EINTR caused by a signal). This should not
1239
               --  happen with the current Linux implementation of pthread, but
1240
               --  POSIX does not guarantee it so this may change in future.
1241
 
1242
               Result := pthread_cond_wait (S.CV'Access, S.L'Access);
1243
               pragma Assert (Result = 0 or else Result = EINTR);
1244
 
1245
               exit when not S.Waiting;
1246
            end loop;
1247
         end if;
1248
 
1249
         Result := pthread_mutex_unlock (S.L'Access);
1250
         pragma Assert (Result = 0);
1251
 
1252
         SSL.Abort_Undefer.all;
1253
      end if;
1254
   end Suspend_Until_True;
1255
 
1256
   ----------------
1257
   -- Check_Exit --
1258
   ----------------
1259
 
1260
   --  Dummy version
1261
 
1262
   function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
1263
      pragma Unreferenced (Self_ID);
1264
   begin
1265
      return True;
1266
   end Check_Exit;
1267
 
1268
   --------------------
1269
   -- Check_No_Locks --
1270
   --------------------
1271
 
1272
   function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
1273
      pragma Unreferenced (Self_ID);
1274
   begin
1275
      return True;
1276
   end Check_No_Locks;
1277
 
1278
   ----------------------
1279
   -- Environment_Task --
1280
   ----------------------
1281
 
1282
   function Environment_Task return Task_Id is
1283
   begin
1284
      return Environment_Task_Id;
1285
   end Environment_Task;
1286
 
1287
   ------------------
1288
   -- Suspend_Task --
1289
   ------------------
1290
 
1291
   function Suspend_Task
1292
     (T           : ST.Task_Id;
1293
      Thread_Self : Thread_Id) return Boolean
1294
   is
1295
   begin
1296
      if T.Common.LL.Thread /= Thread_Self then
1297
         return pthread_kill (T.Common.LL.Thread, SIGSTOP) = 0;
1298
      else
1299
         return True;
1300
      end if;
1301
   end Suspend_Task;
1302
 
1303
   -----------------
1304
   -- Resume_Task --
1305
   -----------------
1306
 
1307
   function Resume_Task
1308
     (T           : ST.Task_Id;
1309
      Thread_Self : Thread_Id) return Boolean
1310
   is
1311
   begin
1312
      if T.Common.LL.Thread /= Thread_Self then
1313
         return pthread_kill (T.Common.LL.Thread, SIGCONT) = 0;
1314
      else
1315
         return True;
1316
      end if;
1317
   end Resume_Task;
1318
 
1319
   --------------------
1320
   -- Stop_All_Tasks --
1321
   --------------------
1322
 
1323
   procedure Stop_All_Tasks is
1324
   begin
1325
      null;
1326
   end Stop_All_Tasks;
1327
 
1328
   ---------------
1329
   -- Stop_Task --
1330
   ---------------
1331
 
1332
   function Stop_Task (T : ST.Task_Id) return Boolean is
1333
      pragma Unreferenced (T);
1334
   begin
1335
      return False;
1336
   end Stop_Task;
1337
 
1338
   -------------------
1339
   -- Continue_Task --
1340
   -------------------
1341
 
1342
   function Continue_Task (T : ST.Task_Id) return Boolean is
1343
      pragma Unreferenced (T);
1344
   begin
1345
      return False;
1346
   end Continue_Task;
1347
 
1348
   ----------------
1349
   -- Initialize --
1350
   ----------------
1351
 
1352
   procedure Initialize (Environment_Task : Task_Id) is
1353
      act     : aliased struct_sigaction;
1354
      old_act : aliased struct_sigaction;
1355
      Tmp_Set : aliased sigset_t;
1356
      Result  : Interfaces.C.int;
1357
      --  Whether to use an alternate signal stack for stack overflows
1358
 
1359
      function State
1360
        (Int : System.Interrupt_Management.Interrupt_ID) return Character;
1361
      pragma Import (C, State, "__gnat_get_interrupt_state");
1362
      --  Get interrupt state.  Defined in a-init.c
1363
      --  The input argument is the interrupt number,
1364
      --  and the result is one of the following:
1365
 
1366
      Default : constant Character := 's';
1367
      --    'n'   this interrupt not set by any Interrupt_State pragma
1368
      --    'u'   Interrupt_State pragma set state to User
1369
      --    'r'   Interrupt_State pragma set state to Runtime
1370
      --    's'   Interrupt_State pragma set state to System (use "default"
1371
      --           system handler)
1372
 
1373
      use type System.Multiprocessors.CPU_Range;
1374
 
1375
   begin
1376
      Environment_Task_Id := Environment_Task;
1377
 
1378
      Interrupt_Management.Initialize;
1379
 
1380
      --  Prepare the set of signals that should be unblocked in all tasks
1381
 
1382
      Result := sigemptyset (Unblocked_Signal_Mask'Access);
1383
      pragma Assert (Result = 0);
1384
 
1385
      for J in Interrupt_Management.Interrupt_ID loop
1386
         if System.Interrupt_Management.Keep_Unmasked (J) then
1387
            Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
1388
            pragma Assert (Result = 0);
1389
         end if;
1390
      end loop;
1391
 
1392
      Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1393
 
1394
      --  Initialize the global RTS lock
1395
 
1396
      Specific.Initialize (Environment_Task);
1397
 
1398
      if Use_Alternate_Stack then
1399
         Environment_Task.Common.Task_Alternate_Stack :=
1400
           Alternate_Stack'Address;
1401
      end if;
1402
 
1403
      --  Make environment task known here because it doesn't go through
1404
      --  Activate_Tasks, which does it for all other tasks.
1405
 
1406
      Known_Tasks (Known_Tasks'First) := Environment_Task;
1407
      Environment_Task.Known_Tasks_Index := Known_Tasks'First;
1408
 
1409
      Enter_Task (Environment_Task);
1410
 
1411
      if State
1412
          (System.Interrupt_Management.Abort_Task_Interrupt) /= Default
1413
      then
1414
         act.sa_flags := 0;
1415
         act.sa_handler := Abort_Handler'Address;
1416
 
1417
         Result := sigemptyset (Tmp_Set'Access);
1418
         pragma Assert (Result = 0);
1419
         act.sa_mask := Tmp_Set;
1420
 
1421
         Result :=
1422
           sigaction
1423
           (Signal (Interrupt_Management.Abort_Task_Interrupt),
1424
            act'Unchecked_Access,
1425
            old_act'Unchecked_Access);
1426
         pragma Assert (Result = 0);
1427
         Abort_Handler_Installed := True;
1428
      end if;
1429
 
1430
      --  pragma CPU and dispatching domains for the environment task
1431
 
1432
      Set_Task_Affinity (Environment_Task);
1433
   end Initialize;
1434
 
1435
   -----------------------
1436
   -- Set_Task_Affinity --
1437
   -----------------------
1438
 
1439
   procedure Set_Task_Affinity (T : ST.Task_Id) is
1440
      use type System.Multiprocessors.CPU_Range;
1441
 
1442
   begin
1443
      --  Do nothing if there is no support for setting affinities or the
1444
      --  underlying thread has not yet been created. If the thread has not
1445
      --  yet been created then the proper affinity will be set during its
1446
      --  creation.
1447
 
1448
      if pthread_setaffinity_np'Address /= System.Null_Address
1449
        and then T.Common.LL.Thread /= Null_Thread_Id
1450
      then
1451
         declare
1452
            CPUs    : constant size_t :=
1453
                        Interfaces.C.size_t
1454
                          (System.Multiprocessors.Number_Of_CPUs);
1455
            CPU_Set : cpu_set_t_ptr := null;
1456
            Size    : constant size_t := CPU_ALLOC_SIZE (CPUs);
1457
 
1458
            Result  : Interfaces.C.int;
1459
 
1460
         begin
1461
            --  We look at the specific CPU (Base_CPU) first, then at the
1462
            --  Task_Info field, and finally at the assigned dispatching
1463
            --  domain, if any.
1464
 
1465
            if T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then
1466
 
1467
               --  Set the affinity to an unique CPU
1468
 
1469
               CPU_Set := CPU_ALLOC (CPUs);
1470
               System.OS_Interface.CPU_ZERO (Size, CPU_Set);
1471
               System.OS_Interface.CPU_SET
1472
                 (int (T.Common.Base_CPU), Size, CPU_Set);
1473
 
1474
            --  Handle Task_Info
1475
 
1476
            elsif T.Common.Task_Info /= null then
1477
               CPU_Set := T.Common.Task_Info.CPU_Affinity'Access;
1478
 
1479
            --  Handle dispatching domains
1480
 
1481
            elsif T.Common.Domain /= null and then
1482
              (T.Common.Domain /= ST.System_Domain
1483
                or else T.Common.Domain.all /=
1484
                          (Multiprocessors.CPU'First ..
1485
                           Multiprocessors.Number_Of_CPUs => True))
1486
            then
1487
               --  Set the affinity to all the processors belonging to the
1488
               --  dispatching domain. To avoid changing CPU affinities when
1489
               --  not needed, we set the affinity only when assigning to a
1490
               --  domain other than the default one, or when the default one
1491
               --  has been modified.
1492
 
1493
               CPU_Set := CPU_ALLOC (CPUs);
1494
               System.OS_Interface.CPU_ZERO (Size, CPU_Set);
1495
 
1496
               for Proc in T.Common.Domain'Range loop
1497
                  System.OS_Interface.CPU_SET (int (Proc), Size, CPU_Set);
1498
               end loop;
1499
            end if;
1500
 
1501
            --  We set the new affinity if needed. Otherwise, the new task
1502
            --  will inherit its creator's CPU affinity mask (according to
1503
            --  the documentation of pthread_setaffinity_np), which is
1504
            --  consistent with Ada's required semantics.
1505
 
1506
            if CPU_Set /= null then
1507
               Result :=
1508
                 pthread_setaffinity_np (T.Common.LL.Thread, Size, CPU_Set);
1509
               pragma Assert (Result = 0);
1510
 
1511
               CPU_FREE (CPU_Set);
1512
            end if;
1513
         end;
1514
      end if;
1515
   end Set_Task_Affinity;
1516
 
1517
end System.Task_Primitives.Operations;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.