2014-07-31 Robert Dewar <dewar@adacore.com>

	* prj-nmsc.adb: Minor reformatting.

2014-07-31  Bob Duff  <duff@adacore.com>

	* s-tasdeb.adb (System.Tasking.Debug): Remove
	all usage of the secondary stack from this package.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@213334 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index d8f1bbb..85f4f7c 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,12 @@
+2014-07-31  Robert Dewar  <dewar@adacore.com>
+
+       * prj-nmsc.adb: Minor reformatting.
+
+2014-07-31  Bob Duff  <duff@adacore.com>
+
+       * s-tasdeb.adb (System.Tasking.Debug): Remove
+       all usage of the secondary stack from this package.
+
 2014-07-31  Hristian Kirtchev  <kirtchev@adacore.com>
 
        * freeze.adb (Freeze_Expression): Update the loop in charge

diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb
index 7d8678a..b9135c2 100644 (file)
--- a/gcc/ada/prj-nmsc.adb
+++ b/gcc/ada/prj-nmsc.adb
@@ -3029,9 +3029,9 @@ package body Prj.Nmsc is
       --  Check if an imported or extended project if also a library project
 
       procedure Check_Aggregate_Library_Dirs;
-      --  Check that the library directory and the library ALI directory of
-      --  an aggregate library project are not the same as the object directory
-      --  or the library directory of any of its aggregated projects.
+      --  Check that the library directory and the library ALI directory of an
+      --  aggregate library project are not the same as the object directory or
+      --  the library directory of any of its aggregated projects.
 
       ----------------------------------
       -- Check_Aggregate_Library_Dirs --

diff --git a/gcc/ada/s-tasdeb.adb b/gcc/ada/s-tasdeb.adb
index e2256f7..d56e0ca 100644 (file)
--- a/gcc/ada/s-tasdeb.adb
+++ b/gcc/ada/s-tasdeb.adb
@@ -37,8 +37,14 @@
 --  Do not add any dependency to GNARL packages since this package is used
 --  in both normal and restricted (ravenscar) environments.
 
-with System.Address_Image;
+pragma Restriction_Warnings (No_Secondary_Stack);
+--  We wish to avoid secondary stack usage here, because (e.g.) Trace is called
+--  at delicate times, such as during task termination after the secondary
+--  stack has been deallocated. It's just a warning, so we don't require
+--  partition-wide consistency.
+
 with System.CRTL;
+with System.Storage_Elements; use System.Storage_Elements;
 with System.Task_Primitives;
 with System.Task_Primitives.Operations;
 
@@ -66,11 +72,11 @@ package body System.Tasking.Debug is
    procedure Put_Line (S : String := "");
    --  Display S on standard error with an additional line terminator
 
-   function Task_Image (T : Task_Id) return String;
-   --  Return the relevant characters from T.Common.Task_Image
+   procedure Put_Task_Image (T : Task_Id);
+   --  Display relevant characters from T.Common.Task_Image on standard error
 
-   function Task_Id_Image (T : Task_Id) return String;
-   --  Return the address in hexadecimal form
+   procedure Put_Task_Id_Image (T : Task_Id);
+   --  Display address in hexadecimal form on standard error
 
    ------------------------
    -- Continue_All_Tasks --
@@ -109,7 +115,6 @@ package body System.Tasking.Debug is
       C : Task_Id;
    begin
       C := All_Tasks_List;
-
       while C /= null loop
          Print_Task_Info (C);
          C := C.Common.All_Tasks_Link;
@@ -139,13 +144,15 @@ package body System.Tasking.Debug is
          return;
       end if;
 
-      Put (Task_Image (T) & ": " & Task_States'Image (T.Common.State));
+      Put_Task_Image (T);
+      Put (": " & Task_States'Image (T.Common.State));
       Parent := T.Common.Parent;
 
       if Parent = null then
          Put (", parent: <none>");
       else
-         Put (", parent: " & Task_Image (Parent));
+         Put (", parent: ");
+         Put_Task_Image (Parent);
       end if;
 
       Put (", prio:" & T.Common.Current_Priority'Img);
@@ -167,7 +174,7 @@ package body System.Tasking.Debug is
          Put (", serving:");
 
          while Entry_Call /= null loop
-            Put (Task_Id_Image (Entry_Call.Self));
+            Put_Task_Id_Image (Entry_Call.Self);
             Entry_Call := Entry_Call.Acceptor_Prev_Call;
          end loop;
       end if;
@@ -209,6 +216,66 @@ package body System.Tasking.Debug is
       Write (Stderr_Fd, S & ASCII.LF, S'Length + 1);
    end Put_Line;
 
+   -----------------------
+   -- Put_Task_Id_Image --
+   -----------------------
+
+   procedure Put_Task_Id_Image (T : Task_Id) is
+      Address_Image_Length : constant :=
+        13 + (if Standard'Address_Size = 64 then 10 else 0);
+      --  Length of string to be printed for address of task
+
+      H : constant array (0 .. 15) of Character := "0123456789ABCDEF";
+      --  Table of hex digits
+
+      S : String (1 .. Address_Image_Length);
+      P : Natural;
+      N : Integer_Address;
+      U : Natural := 0;
+
+   begin
+      if T = null then
+         Put ("Null_Task_Id");
+
+      else
+         S (S'Last) := '#';
+         P := Address_Image_Length - 1;
+         N := To_Integer (T.all'Address);
+         while P > 3 loop
+            if U = 4 then
+               S (P) := '_';
+               P := P - 1;
+               U := 1;
+            else
+               U := U + 1;
+            end if;
+
+            S (P) := H (Integer (N mod 16));
+            P := P - 1;
+            N := N / 16;
+         end loop;
+
+         S (1 .. 3) := "16#";
+         Put (S);
+      end if;
+   end Put_Task_Id_Image;
+
+   --------------------
+   -- Put_Task_Image --
+   --------------------
+
+   procedure Put_Task_Image (T : Task_Id) is
+   begin
+      --  In case T.Common.Task_Image_Len is uninitialized junk, we check that
+      --  it is in range, to make this more robust.
+
+      if T.Common.Task_Image_Len in T.Common.Task_Image'Range then
+         Put (T.Common.Task_Image (1 .. T.Common.Task_Image_Len));
+      else
+         Put (T.Common.Task_Image);
+      end if;
+   end Put_Task_Image;
+
    ----------------------
    -- Resume_All_Tasks --
    ----------------------
@@ -219,8 +286,8 @@ package body System.Tasking.Debug is
 
    begin
       STPO.Lock_RTS;
-      C := All_Tasks_List;
 
+      C := All_Tasks_List;
       while C /= null loop
          Dummy := STPO.Resume_Task (C, Thread_Self);
          C := C.Common.All_Tasks_Link;
@@ -298,8 +365,8 @@ package body System.Tasking.Debug is
 
    begin
       STPO.Lock_RTS;
-      C := All_Tasks_List;
 
+      C := All_Tasks_List;
       while C /= null loop
          Dummy := STPO.Suspend_Task (C, Thread_Self);
          C := C.Common.All_Tasks_Link;
@@ -321,35 +388,6 @@ package body System.Tasking.Debug is
       null;
    end Task_Creation_Hook;
 
-   ----------------
-   -- Task_Id_Image --
-   ----------------
-
-   function Task_Id_Image (T : Task_Id) return String is
-   begin
-      if T = null then
-         return "Null_Task_Id";
-      else
-         return Address_Image (T.all'Address);
-      end if;
-   end Task_Id_Image;
-
-   ----------------
-   -- Task_Image --
-   ----------------
-
-   function Task_Image (T : Task_Id) return String is
-   begin
-      --  In case T.Common.Task_Image_Len is uninitialized junk, we check that
-      --  it is in range, to make this more robust.
-
-      if T.Common.Task_Image_Len in T.Common.Task_Image'Range then
-         return T.Common.Task_Image (1 .. T.Common.Task_Image_Len);
-      else
-         return T.Common.Task_Image;
-      end if;
-   end Task_Image;
-
    ---------------------------
    -- Task_Termination_Hook --
    ---------------------------
@@ -371,13 +409,14 @@ package body System.Tasking.Debug is
    is
    begin
       if Trace_On (Flag) then
-         Put (Task_Id_Image (Self_Id) &
-              ':' & Flag & ':' &
-              Task_Image (Self_Id) &
-              ':');
+         Put_Task_Id_Image (Self_Id);
+         Put (":" & Flag & ":");
+         Put_Task_Image (Self_Id);
+         Put (":");
 
          if Other_Id /= null then
-            Put (Task_Id_Image (Other_Id) & ':');
+            Put_Task_Id_Image (Other_Id);
+            Put (":");
          end if;
 
          Put_Line (Msg);