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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [ada/] [s-taprop-linux.adb] - Blame information for rev 826

Details | Compare with Previous | View Log

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