gcc/ada/libgnarl/s-stusta.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
   4 --                                                                          --
   5 --            S Y S T E M . S T A C K _ U S A G E . T A S K I N G           --
   6 --                                                                          --
   7 --                                  B o d y                                 --
   8 --                                                                          --
   9 --           Copyright (C) 2009-2023, Free Software Foundation, Inc.        --
  10 --                                                                          --
  11 -- GNAT 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 why this package is part of GNARL:
  33
  34 with System.Tasking.Debug;
  35 with System.Task_Primitives.Operations;
  36
  37 with System.IO;
  38
  39 package body System.Stack_Usage.Tasking is
  40    use System.IO;
  41
  42    procedure Report_For_Task (Id : System.Tasking.Task_Id);
  43    --  A generic procedure calculating stack usage for a given task
  44
  45    procedure Compute_All_Tasks;
  46    --  Compute the stack usage for all tasks and saves it in
  47    --  System.Stack_Usage.Result_Array
  48
  49    procedure Compute_Current_Task;
  50    --  Compute the stack usage for a given task and saves it in the precise
  51    --  slot in System.Stack_Usage.Result_Array;
  52
  53    procedure Report_Impl (All_Tasks : Boolean; Do_Print : Boolean);
  54    --  Report the stack usage of either all tasks (All_Tasks = True) or of the
  55    --  current task (All_Task = False). If Print is True, then results are
  56    --  printed on stderr
  57
  58    procedure Convert
  59      (TS  : System.Stack_Usage.Task_Result;
  60       Res : out Stack_Usage_Result);
  61    --  Convert an object of type System.Stack_Usage in a Stack_Usage_Result
  62
  63    -------------
  64    -- Convert --
  65    -------------
  66
  67    procedure Convert
  68      (TS  : System.Stack_Usage.Task_Result;
  69       Res : out Stack_Usage_Result) is
  70    begin
  71       Res := TS;
  72    end Convert;
  73
  74    ---------------------
  75    -- Report_For_Task --
  76    ---------------------
  77
  78    procedure Report_For_Task (Id : System.Tasking.Task_Id) is
  79    begin
  80       System.Stack_Usage.Compute_Result (Id.Common.Analyzer);
  81       System.Stack_Usage.Report_Result (Id.Common.Analyzer);
  82    end Report_For_Task;
  83
  84    -----------------------
  85    -- Compute_All_Tasks --
  86    -----------------------
  87
  88    procedure Compute_All_Tasks is
  89       Id : System.Tasking.Task_Id;
  90       use type System.Tasking.Task_Id;
  91    begin
  92       if not System.Stack_Usage.Is_Enabled then
  93          Put_Line ("Stack Usage not enabled: bind with -uNNN switch");
  94       else
  95
  96          --  Loop over all tasks
  97
  98          for J in System.Tasking.Debug.Known_Tasks'First + 1
  99            .. System.Tasking.Debug.Known_Tasks'Last
 100          loop
 101             Id := System.Tasking.Debug.Known_Tasks (J);
 102             exit when Id = null;
 103
 104             --  Calculate the task usage for a given task
 105
 106             Report_For_Task (Id);
 107          end loop;
 108
 109       end if;
 110    end Compute_All_Tasks;
 111
 112    --------------------------
 113    -- Compute_Current_Task --
 114    --------------------------
 115
 116    procedure Compute_Current_Task is
 117    begin
 118       if not System.Stack_Usage.Is_Enabled then
 119          Put_Line ("Stack Usage not enabled: bind with -uNNN switch");
 120       else
 121
 122          --  The current task
 123
 124          Report_For_Task (System.Tasking.Self);
 125
 126       end if;
 127    end Compute_Current_Task;
 128
 129    -----------------
 130    -- Report_Impl --
 131    -----------------
 132
 133    procedure Report_Impl (All_Tasks : Boolean; Do_Print : Boolean) is
 134    begin
 135
 136       --  Lock the runtime
 137
 138       System.Task_Primitives.Operations.Lock_RTS;
 139
 140       --  Calculate results
 141
 142       if All_Tasks then
 143          Compute_All_Tasks;
 144       else
 145          Compute_Current_Task;
 146       end if;
 147
 148       --  Output results
 149       if Do_Print then
 150          System.Stack_Usage.Output_Results;
 151       end if;
 152
 153       --  Unlock the runtime
 154
 155       System.Task_Primitives.Operations.Unlock_RTS;
 156
 157    end Report_Impl;
 158
 159    ----------------------
 160    -- Report_All_Tasks --
 161    ----------------------
 162
 163    procedure Report_All_Tasks is
 164    begin
 165       Report_Impl (True, True);
 166    end Report_All_Tasks;
 167
 168    -------------------------
 169    -- Report_Current_Task --
 170    -------------------------
 171
 172    procedure Report_Current_Task is
 173       Res : Stack_Usage_Result;
 174    begin
 175       Res := Get_Current_Task_Usage;
 176       Print (Res);
 177    end Report_Current_Task;
 178
 179    -------------------------
 180    -- Get_All_Tasks_Usage --
 181    -------------------------
 182
 183    function Get_All_Tasks_Usage return Stack_Usage_Result_Array is
 184       Res : Stack_Usage_Result_Array
 185         (1 .. System.Stack_Usage.Result_Array'Length);
 186    begin
 187       Report_Impl (True, False);
 188
 189       for J in Res'Range loop
 190          Convert (System.Stack_Usage.Result_Array (J), Res (J));
 191       end loop;
 192
 193       return Res;
 194    end Get_All_Tasks_Usage;
 195
 196    ----------------------------
 197    -- Get_Current_Task_Usage --
 198    ----------------------------
 199
 200    function Get_Current_Task_Usage return Stack_Usage_Result is
 201       Res : Stack_Usage_Result;
 202       Original : System.Stack_Usage.Task_Result;
 203       Found : Boolean := False;
 204    begin
 205
 206       Report_Impl (False, False);
 207
 208       --  Look for the task info in System.Stack_Usage.Result_Array;
 209       --  the search is based on task name
 210
 211       for T in System.Stack_Usage.Result_Array'Range loop
 212          if System.Stack_Usage.Result_Array (T).Task_Name =
 213            System.Tasking.Self.Common.Analyzer.Task_Name
 214          then
 215             Original := System.Stack_Usage.Result_Array (T);
 216             Found := True;
 217             exit;
 218          end if;
 219       end loop;
 220
 221       --  Be sure a task has been found
 222
 223       pragma Assert (Found);
 224
 225       Convert (Original, Res);
 226       return Res;
 227    end Get_Current_Task_Usage;
 228
 229    -----------
 230    -- Print --
 231    -----------
 232
 233    procedure Print (Obj : Stack_Usage_Result) is
 234       Pos : Positive := Obj.Task_Name'Last;
 235
 236    begin
 237       --  Simply trim the string containing the task name
 238
 239       for S in Obj.Task_Name'Range loop
 240          if Obj.Task_Name (S) = ' ' then
 241             Pos := S;
 242             exit;
 243          end if;
 244       end loop;
 245
 246       declare
 247          T_Name : constant String :=
 248                     Obj.Task_Name (Obj.Task_Name'First .. Pos);
 249       begin
 250          Put_Line
 251            ("| " & T_Name & " | " & Natural'Image (Obj.Stack_Size) &
 252             Natural'Image (Obj.Value));
 253       end;
 254    end Print;
 255
 256 end System.Stack_Usage.Tasking;