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

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [s-taprop-solaris.adb] - Blame information for rev 414

Go to most recent revision | Details | Compare with Previous | View Log

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