2010-12-06 Jerry DeLisle <jvdelisle@gcc.gnu.org>

[pf3gnuchains/gcc-fork.git] / gcc / ada / s-taprop-vms.adb

diff --git a/gcc/ada/s-taprop-vms.adb b/gcc/ada/s-taprop-vms.adb
index 4a36f8b..582f88b 100644 (file)
--- a/gcc/ada/s-taprop-vms.adb
+++ b/gcc/ada/s-taprop-vms.adb
@@ -408,15 +408,12 @@ package body System.Task_Primitives.Operations is
       Result : Interfaces.C.int;
 
    begin
-      if Single_Lock then
-         Result :=
-           pthread_cond_wait
-             (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
-      else
-         Result :=
-           pthread_cond_wait
-             (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
-      end if;
+      Result :=
+        pthread_cond_wait
+          (cond  => Self_ID.Common.LL.CV'Access,
+           mutex => (if Single_Lock
+                     then Single_RTS_Lock'Access
+                     else Self_ID.Common.LL.L'Access));
 
       --  EINTR is not considered a failure
 
@@ -540,19 +537,13 @@ package body System.Task_Primitives.Operations is
                   exit;
                end if;
 
-               if Single_Lock then
-                  Result :=
-                    pthread_cond_wait
-                      (Self_ID.Common.LL.CV'Access,
-                       Single_RTS_Lock'Access);
-                  pragma Assert (Result = 0);
-               else
-                  Result :=
-                    pthread_cond_wait
-                      (Self_ID.Common.LL.CV'Access,
-                       Self_ID.Common.LL.L'Access);
-                  pragma Assert (Result = 0);
-               end if;
+               Result :=
+                 pthread_cond_wait
+                   (cond  => Self_ID.Common.LL.CV'Access,
+                    mutex => (if Single_Lock
+                              then Single_RTS_Lock'Access
+                              else Self_ID.Common.LL.L'Access));
+               pragma Assert (Result = 0);
 
                Yielded := True;
 
@@ -689,20 +680,7 @@ package body System.Task_Primitives.Operations is
    procedure Enter_Task (Self_ID : Task_Id) is
    begin
       Self_ID.Common.LL.Thread := pthread_self;
-
       Specific.Set (Self_ID);
-
-      Lock_RTS;
-
-      for J in Known_Tasks'Range loop
-         if Known_Tasks (J) = null then
-            Known_Tasks (J) := Self_ID;
-            Self_ID.Known_Tasks_Index := J;
-            exit;
-         end if;
-      end loop;
-
-      Unlock_RTS;
    end Enter_Task;
 
    --------------
@@ -1117,7 +1095,16 @@ package body System.Task_Primitives.Operations is
             S.State := False;
          else
             S.Waiting := True;
-            Result := pthread_cond_wait (S.CV'Access, S.L'Access);
+
+            loop
+               --  Loop in case pthread_cond_wait returns earlier than expected
+               --  (e.g. in case of EINTR caused by a signal).
+
+               Result := pthread_cond_wait (S.CV'Access, S.L'Access);
+               pragma Assert (Result = 0 or else Result = EINTR);
+
+               exit when not S.Waiting;
+            end loop;
          end if;
 
          Result := pthread_mutex_unlock (S.L'Access);
@@ -1238,6 +1225,25 @@ package body System.Task_Primitives.Operations is
    ----------------
 
    procedure Initialize (Environment_Task : Task_Id) is
+
+      --  The DEC Ada facility code defined in Starlet
+      Ada_Facility : constant := 49;
+
+      function DBGEXT (Control_Block : System.Address)
+        return System.Aux_DEC.Unsigned_Word;
+      --  DBGEXT is imported  from s-tasdeb.adb and its parameter re-typed
+      --  as Address to avoid having a VMS specific s-tasdeb.ads.
+      pragma Interface (C, DBGEXT);
+      pragma Import_Function (DBGEXT, "GNAT$DBGEXT");
+
+      type Facility_Type is range 0 .. 65535;
+
+      procedure Debug_Register
+        (ADBGEXT    : System.Address;
+         ATCB_Key   : pthread_key_t;
+         Facility   : Facility_Type;
+         Std_Prolog : Integer);
+      pragma Import (C, Debug_Register, "CMA$DEBUG_REGISTER");
    begin
       Environment_Task_Id := Environment_Task;
 
@@ -1249,6 +1255,21 @@ package body System.Task_Primitives.Operations is
 
       Specific.Initialize (Environment_Task);
 
+      --  Pass the context key on to CMA along with the other parameters
+      Debug_Register
+       (
+        DBGEXT'Address,    --  Our DEBUG handling entry point
+        ATCB_Key,          --  CMA context key for our Ada TCB's
+        Ada_Facility,      --  Out facility code
+        0                  --  False, we don't have the std TCB prolog
+       );
+
+      --  Make environment task known here because it doesn't go through
+      --  Activate_Tasks, which does it for all other tasks.
+
+      Known_Tasks (Known_Tasks'First) := Environment_Task;
+      Environment_Task.Known_Tasks_Index := Known_Tasks'First;
+
       Enter_Task (Environment_Task);
    end Initialize;