1------------------------------------------------------------------------------
2--                                                                          --
3--                GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS               --
4--                                                                          --
5--                   SYSTEM.TASK_PRIMITIVES.OPERATIONS.DEC                  --
6--                                                                          --
7--                                  B o d y                                 --
8--                                                                          --
9--           Copyright (C) 2000-2003 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 2,  or (at your option) any later ver- --
14-- sion. GNARL 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.  See the GNU General Public License --
17-- for  more details.  You should have  received  a copy of the GNU General --
18-- Public License  distributed with GNARL; see file COPYING.  If not, write --
19-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
20-- MA 02111-1307, USA.                                                      --
21--                                                                          --
22-- As a special exception,  if other files  instantiate  generics from this --
23-- unit, or you link  this unit with other files  to produce an executable, --
24-- this  unit  does not  by itself cause  the resulting  executable  to  be --
25-- covered  by the  GNU  General  Public  License.  This exception does not --
26-- however invalidate  any other reasons why  the executable file  might be --
27-- covered by the  GNU Public License.                                      --
28--                                                                          --
29-- GNARL was developed by the GNARL team at Florida State University.       --
30-- Extensive contributions were provided by Ada Core Technologies, Inc.     --
31--                                                                          --
32------------------------------------------------------------------------------
33
34--   This package is for OpenVMS/Alpha
35
36with System.OS_Interface;
37with System.Parameters;
38with System.Tasking;
39with Unchecked_Conversion;
40with System.Soft_Links;
41
42package body System.Task_Primitives.Operations.DEC is
43
44   use System.OS_Interface;
45   use System.Parameters;
46   use System.Tasking;
47   use System.Aux_DEC;
48   use type Interfaces.C.int;
49
50   package SSL renames System.Soft_Links;
51
52   --  The FAB_RAB_Type specifies where the context field (the calling
53   --  task) is stored.  Other fields defined for FAB_RAB arent' need and
54   --  so are ignored.
55
56   type FAB_RAB_Type is record
57      CTX : Unsigned_Longword;
58   end record;
59
60   for FAB_RAB_Type use record
61      CTX at 24 range 0 .. 31;
62   end record;
63
64   for FAB_RAB_Type'Size use 224;
65
66   type FAB_RAB_Access_Type is access all FAB_RAB_Type;
67
68   -----------------------
69   -- Local Subprograms --
70   -----------------------
71
72   function To_Unsigned_Longword is new
73     Unchecked_Conversion (Task_ID, Unsigned_Longword);
74
75   function To_Task_Id is new
76     Unchecked_Conversion (Unsigned_Longword, Task_ID);
77
78   function To_FAB_RAB is new
79     Unchecked_Conversion (Address, FAB_RAB_Access_Type);
80
81   ---------------------------
82   -- Interrupt_AST_Handler --
83   ---------------------------
84
85   procedure Interrupt_AST_Handler (ID : Address) is
86      Result      : Interfaces.C.int;
87      AST_Self_ID : Task_ID := To_Task_Id (ID);
88
89   begin
90      Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access);
91      pragma Assert (Result = 0);
92   end Interrupt_AST_Handler;
93
94   ---------------------
95   -- RMS_AST_Handler --
96   ---------------------
97
98   procedure RMS_AST_Handler (ID : Address) is
99      AST_Self_ID : Task_ID := To_Task_Id (To_FAB_RAB (ID).CTX);
100      Result      : Interfaces.C.int;
101
102   begin
103      AST_Self_ID.Common.LL.AST_Pending := False;
104      Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access);
105      pragma Assert (Result = 0);
106   end RMS_AST_Handler;
107
108   ----------
109   -- Self --
110   ----------
111
112   function Self return Unsigned_Longword is
113      Self_ID : Task_ID := Self;
114   begin
115      Self_ID.Common.LL.AST_Pending := True;
116      return To_Unsigned_Longword (Self);
117   end Self;
118
119   -------------------------
120   -- Starlet_AST_Handler --
121   -------------------------
122
123   procedure Starlet_AST_Handler (ID : Address) is
124      Result      : Interfaces.C.int;
125      AST_Self_ID : Task_ID := To_Task_Id (ID);
126
127   begin
128      AST_Self_ID.Common.LL.AST_Pending := False;
129      Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access);
130      pragma Assert (Result = 0);
131   end Starlet_AST_Handler;
132
133   ----------------
134   -- Task_Synch --
135   ----------------
136
137   procedure Task_Synch is
138      Synch_Self_ID : constant Task_ID := Self;
139   begin
140      if Single_Lock then
141         Lock_RTS;
142      else
143         Write_Lock (Synch_Self_ID);
144      end if;
145
146      SSL.Abort_Defer.all;
147      Synch_Self_ID.Common.State := AST_Server_Sleep;
148
149      while Synch_Self_ID.Common.LL.AST_Pending loop
150         Sleep (Synch_Self_ID, AST_Server_Sleep);
151      end loop;
152
153      Synch_Self_ID.Common.State := Runnable;
154
155      if Single_Lock then
156         Unlock_RTS;
157      else
158         Unlock (Synch_Self_ID);
159      end if;
160
161      SSL.Abort_Undefer.all;
162   end Task_Synch;
163
164end System.Task_Primitives.Operations.DEC;
165