------------------------------------------------------------------------------
-- Language Server Protocol --
-- --
-- Copyright (C) 2020, AdaCore --
-- --
-- This is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public --
-- License for more details. You should have received a copy of the GNU --
-- General Public License distributed with this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
with Ada.Characters.Latin_1;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with GNAT.Regpat; use GNAT.Regpat;
with GNAT.Traceback.Symbolic; use GNAT.Traceback.Symbolic;
with System.Address_Image;
with System.Storage_Elements; use System.Storage_Elements;
package body LSP.Memory_Statistics is
----------------------------
-- Dump_Memory_Statistics --
----------------------------
function Dump_Memory_Statistics
(Size : Positive;
Report : Report_Type := Memory_Usage)
return String
is
Buffer : Unbounded_String := To_Unbounded_String
("Dump_Memory_Statistics at 0x" &
System.Address_Image (Dump_Memory_Statistics'Address) &
Ada.Characters.Latin_1.LF);
Traceback_Regexp : constant Pattern_Matcher :=
Compile ("\s0x0+([0-9a-zA-Z]+)");
procedure Trace_Put (S : String);
procedure Trace_Put_Line (S : String);
---------------
-- Trace_Put --
---------------
procedure Trace_Put (S : String) is
Matched : Match_Array (0 .. 1);
begin
Match (Traceback_Regexp, S, Matched);
-- If we are dealing with traceback addresses, resolve it to the
-- actual source location using GNAT.Traceback.Symbolic.
-- This is needed since these addresses can point to relocatable
-- libraries, in which case addr2line won't be able to find the
-- corresponding source locations.
if Matched (0) = No_Match then
Append (Buffer, S);
else
declare
Traceback_Str : constant String :=
S (Matched (1).First .. Matched (1).Last);
Traceback_Long : constant Long_Integer :=
Long_Integer'Value
("16#" & Traceback_Str & "#");
Traceback_Addr : constant System.Address :=
To_Address
(Integer_Address (Traceback_Long));
New_S : constant String :=
Symbolic_Traceback_No_Hex
((1 => Traceback_Addr));
begin
Append (Buffer, New_S);
end;
end if;
end Trace_Put;
--------------------
-- Trace_Put_Line --
--------------------
procedure Trace_Put_Line (S : String) is
begin
Append (Buffer, S & Ada.Characters.Latin_1.LF);
end Trace_Put_Line;
procedure Internal is new GNATCOLL.Memory.Redirectable_Dump
(Put_Line => Trace_Put_Line,
Put => Trace_Put);
begin
Internal (Size, Report);
return To_String (Buffer);
end Dump_Memory_Statistics;
end LSP.Memory_Statistics;