tracebak.c: Use tb-ivms.c on OpenVMS Itanium.

2007-08-14  Tristan Gingold  <gingold@adacore.com>

	* tracebak.c: Use tb-ivms.c on OpenVMS Itanium.

	* tb-ivms.c: New file.

	* g-trasym-vms-ia64.adb: Fixed for OpenVMS version 8.2

From-SVN: r127466

3 files changed, 237 insertions, 134 deletions

diff --git a/gcc/ada/g-trasym-vms-ia64.adb b/gcc/ada/g-trasym-vms-ia64.adb
index 7636a64..374b0ae 100644
--- a/gcc/ada/g-trasym-vms-ia64.adb
+++ b/gcc/ada/g-trasym-vms-ia64.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---         Copyright (C) 2005-2006, Free Software Foundation, Inc.          --
+--         Copyright (C) 2005-2007, Free Software Foundation, Inc.          --
 --                                                                          --
 -- GNAT 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- --
@@ -34,7 +34,6 @@
 --  Run-time symbolic traceback support for IA64/VMS
 
 with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;
-with Interfaces.C;
 with System;
 with System.Aux_DEC;
 with System.Soft_Links;
@@ -45,57 +44,50 @@ package body GNAT.Traceback.Symbolic is
    pragma Warnings (Off);
    pragma Linker_Options ("--for-linker=sys$library:trace.exe");
 
-   use Interfaces.C;
    use System;
    use System.Aux_DEC;
    use System.Traceback_Entries;
 
-   subtype User_Arg_Type is Unsigned_Longword;
-   subtype Cond_Value_Type is Unsigned_Longword;
+   subtype Var_String_Buf is String (1 .. 254);
 
-   type ASCIC is record
-      Count : unsigned_char;
-      Data  : char_array (1 .. 255);
+   type Var_String is record
+      Curlen : Unsigned_Word := 0;
+      Buf    : Var_String_Buf;
    end record;
-   pragma Convention (C, ASCIC);
-
-   for ASCIC use record
-      Count at 0 range 0 .. 7;
-      Data  at 1 range 0 .. 8 * 255 - 1;
+   pragma Convention (C, Var_String);
+   for Var_String'Size use 8 * 256;
+
+   type Descriptor64 is record
+      Mbo       : Unsigned_Word;
+      Dtype     : Unsigned_Byte;
+      Class     : Unsigned_Byte;
+      Mbmo      : Unsigned_Longword;
+      Maxstrlen : Integer_64;
+      Pointer   : Address;
    end record;
-   for ASCIC'Size use 8 * 256;
-
-   function Fetch_ASCIC is new Fetch_From_Address (ASCIC);
-
-   procedure Symbolize
-     (Status         : out Cond_Value_Type;
-      Current_PC     : Address;
-      Filename_Name  : out Address;
-      Library_Name   : out Address;
-      Record_Number  : out Integer;
-      Image_Name     : out Address;
-      Module_Name    : out Address;
-      Routine_Name   : out Address;
-      Line_Number    : out Integer;
-      Relative_PC    : out Address);
-
-   pragma Interface (External, Symbolize);
-
-   pragma Import_Valued_Procedure
-     (Symbolize, "TBK$I64_SYMBOLIZE",
-      (Cond_Value_Type, Address,
-       Address, Address, Integer,
-       Address, Address, Address, Integer,
-       Address),
-      (Value, Value,
-       Reference, Reference, Reference,
-       Reference, Reference, Reference, Reference,
-       Reference));
+   pragma Convention (C, Descriptor64);
+
+   subtype Cond_Value_Type is Unsigned_Longword;
+
+   function Symbolize
+     (Current_PC    : Address;
+      Filename_Dsc  : Address;
+      Library_Dsc   : Address;
+      Record_Number : Address;
+      Image_Dsc     : Address;
+      Module_Dsc    : Address;
+      Routine_Dsc   : Address;
+      Line_Number   : Address;
+      Relative_PC   : Address) return Cond_Value_Type;
+   pragma Import (C, Symbolize, "TBK$I64_SYMBOLIZE");
 
    function Decode_Ada_Name (Encoded_Name : String) return String;
    --  Decodes an Ada identifier name. Removes leading "_ada_" and trailing
    --  __{DIGIT}+ or ${DIGIT}+, converts other "__" to '.'
 
+   procedure Setup_Descriptor64_Vs (Desc : out Descriptor64; Var : Address);
+   --  Setup descriptor Desc for address Var
+
    ---------------------
    -- Decode_Ada_Name --
    ---------------------
@@ -126,14 +118,17 @@ package body GNAT.Traceback.Symbolic is
             case Encoded_Name (J) is
                when '0' .. '9' =>
                   null;
+
                when '$' =>
                   Last := J - 1;
                   exit;
+
                when '_' =>
                   if Encoded_Name (J - 1) = '_' then
                      Last := J - 2;
                   end if;
                   exit;
+
                when others =>
                   exit;
             end case;
@@ -148,7 +143,6 @@ package body GNAT.Traceback.Symbolic is
          then
             Decoded_Name (DPos) := '.';
             Pos := Pos + 2;
-
          else
             Decoded_Name (DPos) := Encoded_Name (Pos);
             Pos := Pos + 1;
@@ -160,106 +154,121 @@ package body GNAT.Traceback.Symbolic is
       return Decoded_Name (1 .. DPos - 1);
    end Decode_Ada_Name;
 
+   ---------------------------
+   -- Setup_Descriptor64_Vs --
+   ---------------------------
+
+   procedure Setup_Descriptor64_Vs (Desc : out Descriptor64; Var : Address) is
+      K_Dtype_Vt : constant Unsigned_Byte := 37;
+      K_Class_Vs : constant Unsigned_Byte := 11;
+   begin
+      Desc.Mbo := 1;
+      Desc.Dtype := K_Dtype_Vt;
+      Desc.Class := K_Class_Vs;
+      Desc.Mbmo := -1;
+      Desc.Maxstrlen := Integer_64 (Var_String_Buf'Length);
+      Desc.Pointer := Var;
+   end Setup_Descriptor64_Vs;
+
    ------------------------
    -- Symbolic_Traceback --
    ------------------------
 
    function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is
-      Status             : Cond_Value_Type;
-      Filename_Name_Addr : Address;
-      Library_Name_Addr  : Address;
-      Record_Number      : Integer;
-      Image_Name         : ASCIC;
-      Image_Name_Addr    : Address;
-      Module_Name        : ASCIC;
-      Module_Name_Addr   : Address;
-      Routine_Name       : ASCIC;
-      Routine_Name_Addr  : Address;
-      Line_Number        : Integer;
-      Relative_PC        : Address;
-      Res                : String (1 .. 256 * Traceback'Length);
-      Len                : Integer;
+      Status        : Cond_Value_Type;
+      Filename_Name : Var_String;
+      Filename_Dsc  : Descriptor64;
+      Library_Name  : Var_String;
+      Library_Dsc   : Descriptor64;
+      Record_Number : Integer_64;
+      Image_Name    : Var_String;
+      Image_Dsc     : Descriptor64;
+      Module_Name   : Var_String;
+      Module_Dsc    : Descriptor64;
+      Routine_Name  : Var_String;
+      Routine_Dsc   : Descriptor64;
+      Line_Number   : Integer_64;
+      Relative_PC   : Integer_64;
+      Res           : String (1 .. 256 * Traceback'Length);
+      Len           : Integer;
 
    begin
-      if Traceback'Length > 0 then
-         Len := 0;
-
-         --  Since image computation is not thread-safe we need task lockout
-
-         System.Soft_Links.Lock_Task.all;
-
-         for J in Traceback'Range loop
-
-            Symbolize
-              (Status,
-               PC_For (Traceback (J)),
-               Filename_Name_Addr,
-               Library_Name_Addr,
-               Record_Number,
-               Image_Name_Addr,
-               Module_Name_Addr,
-               Routine_Name_Addr,
-               Line_Number,
-               Relative_PC);
-
-            Image_Name   := Fetch_ASCIC (Image_Name_Addr);
-            Module_Name  := Fetch_ASCIC (Module_Name_Addr);
-            Routine_Name := Fetch_ASCIC (Routine_Name_Addr);
-
-            declare
-               First : Integer := Len + 1;
-               Last  : Integer := First + 80 - 1;
-               Pos   : Integer;
-               Routine_Name_D : String := Decode_Ada_Name
-                 (To_Ada
-                    (Routine_Name.Data (1 .. size_t (Routine_Name.Count)),
-                     False));
-
-            begin
-               Res (First .. Last) := (others => ' ');
-
-               Res (First .. First + Integer (Image_Name.Count) - 1) :=
-                 To_Ada
-                  (Image_Name.Data (1 .. size_t (Image_Name.Count)),
-                   False);
-
-               Res (First + 10 ..
-                    First + 10 + Integer (Module_Name.Count) - 1) :=
-                 To_Ada
-                  (Module_Name.Data (1 .. size_t (Module_Name.Count)),
-                   False);
-
-               Res (First + 30 ..
-                    First + 30 + Routine_Name_D'Length - 1) :=
-                 Routine_Name_D;
-
-               --  If routine name doesn't fit 20 characters, output
-               --  the line number on next line at 50th position
-
-               if Routine_Name_D'Length > 20 then
-                  Pos := First + 30 + Routine_Name_D'Length;
-                  Res (Pos) := ASCII.LF;
-                  Last := Pos + 80;
-                  Res (Pos + 1 .. Last) := (others => ' ');
-                  Pos := Pos + 51;
-               else
-                  Pos := First + 50;
-               end if;
-
-               Res (Pos .. Pos + Integer'Image (Line_Number)'Length - 1) :=
-                 Integer'Image (Line_Number);
-
-               Res (Last) := ASCII.LF;
-               Len := Last;
-            end;
-         end loop;
-
-         System.Soft_Links.Unlock_Task.all;
-         return Res (1 .. Len);
-
-      else
+      if Traceback'Length = 0 then
          return "";
       end if;
+
+      Len := 0;
+
+      --  Since image computation is not thread-safe we need task lockout
+
+      System.Soft_Links.Lock_Task.all;
+
+      Setup_Descriptor64_Vs (Filename_Dsc, Filename_Name'Address);
+      Setup_Descriptor64_Vs (Library_Dsc, Library_Name'Address);
+      Setup_Descriptor64_Vs (Image_Dsc, Image_Name'Address);
+      Setup_Descriptor64_Vs (Module_Dsc, Module_Name'Address);
+      Setup_Descriptor64_Vs (Routine_Dsc, Routine_Name'Address);
+
+      for J in Traceback'Range loop
+         Status := Symbolize
+           (PC_For (Traceback (J)),
+            Filename_Dsc'Address,
+            Library_Dsc'Address,
+            Record_Number'Address,
+            Image_Dsc'Address,
+            Module_Dsc'Address,
+            Routine_Dsc'Address,
+            Line_Number'Address,
+            Relative_PC'Address);
+
+         declare
+            First : Integer := Len + 1;
+            Last  : Integer := First + 80 - 1;
+            Pos   : Integer;
+
+            Routine_Name_D : String :=
+                               Decode_Ada_Name
+                                 (Routine_Name.Buf
+                                    (1 .. Natural (Routine_Name.Curlen)));
+
+         begin
+            Res (First .. Last) := (others => ' ');
+
+            Res (First .. First + Natural (Image_Name.Curlen) - 1) :=
+              Image_Name.Buf (1 .. Natural (Image_Name.Curlen));
+
+            Res (First + 10 ..
+                 First + 10 + Natural (Module_Name.Curlen) - 1) :=
+              Module_Name.Buf (1 .. Natural (Module_Name.Curlen));
+
+            Res (First + 30 ..
+                 First + 30 + Routine_Name_D'Length - 1) :=
+              Routine_Name_D;
+
+            --  If routine name doesn't fit 20 characters, output
+            --  the line number on next line at 50th position
+
+            if Routine_Name_D'Length > 20 then
+               Pos := First + 30 + Routine_Name_D'Length;
+               Res (Pos) := ASCII.LF;
+               Last := Pos + 80;
+               Res (Pos + 1 .. Last) := (others => ' ');
+               Pos := Pos + 51;
+            else
+               Pos := First + 50;
+            end if;
+
+            Res (Pos ..
+                 Pos + Integer_64'Image (Line_Number)'Length - 1) :=
+              Integer_64'Image (Line_Number);
+
+            Res (Last) := ASCII.LF;
+            Len := Last;
+         end;
+      end loop;
+
+      System.Soft_Links.Unlock_Task.all;
+      return Res (1 .. Len);
    end Symbolic_Traceback;
 
    function Symbolic_Traceback (E : Exception_Occurrence) return String is
diff --git a/gcc/ada/tb-ivms.c b/gcc/ada/tb-ivms.c
new file mode 100644
index 0000000..24afdb5
--- /dev/null
+++ b/gcc/ada/tb-ivms.c
@@ -0,0 +1,89 @@
+/****************************************************************************
+ *                                                                          *
+ *                         GNAT COMPILER COMPONENTS                         *
+ *                                                                          *
+ *                 T R A C E B A C K - I t a n i u m  / V M S               *
+ *                                                                          *
+ *                          C Implementation File                           *
+ *                                                                          *
+ *                     Copyright (C) 2007, AdaCore                          *
+ *                                                                          *
+ * GNAT 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 2,  or (at your option) any later ver- *
+ * sion.  GNAT is distributed in the hope that it will be useful, but WITH- *
+ * OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY *
+ * 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 GNAT;  see file COPYING.  If not, write *
+ * to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, *
+ * Boston, MA 02110-1301, USA.                                              *
+ *                                                                          *
+ * As a  special  exception,  if you  link  this file  with other  files to *
+ * produce an executable,  this file does not by itself cause the resulting *
+ * executable to be covered by the GNU General Public License. This except- *
+ * ion does not  however invalidate  any other reasons  why the  executable *
+ * file might be covered by the  GNU Public License.                        *
+ *                                                                          *
+ * GNAT was originally developed  by the GNAT team at  New York University. *
+ * Extensive contributions were provided by Ada Core Technologies Inc.      *
+ *                                                                          *
+ ****************************************************************************/
+
+/* Itanium Open/VMS implementation of backtrace.  Use ICB (Invocation
+   Context Block) routines.  */
+#include <stdlib.h>
+#include <vms/libicb.h>
+
+/* Declare libicb routines.  */
+extern INVO_CONTEXT_BLK *LIB$I64_CREATE_INVO_CONTEXT (void *(*)(size_t),
+						      void (*)(void *),
+						      int);
+extern void LIB$I64_FREE_INVO_CONTEXT (INVO_CONTEXT_BLK *);
+extern int LIB$I64_GET_CURR_INVO_CONTEXT(INVO_CONTEXT_BLK *);
+extern int LIB$I64_GET_PREV_INVO_CONTEXT(INVO_CONTEXT_BLK *);
+
+/* Gcc internal headers poison malloc.  So use xmalloc() when building the
+   compiler.  */
+#ifdef IN_RTS
+#define BT_MALLOC malloc
+#else
+#define BT_MALLOC xmalloc
+#endif
+
+int
+__gnat_backtrace (void **array, int size,
+                  void *exclude_min, void *exclude_max, int skip_frames)
+{
+  INVO_CONTEXT_BLK *ctxt;
+  int res = 0;
+  int n = 0;
+
+  /* Create the context.  */
+  ctxt = LIB$I64_CREATE_INVO_CONTEXT (BT_MALLOC, free, 0);
+  if (ctxt == NULL)
+    return 0;
+
+  LIB$I64_GET_CURR_INVO_CONTEXT (ctxt);
+
+  while (1)
+    {
+      void *pc = (void *)ctxt->libicb$ih_pc;
+      if (pc == (void *)0)
+	break;
+      if (ctxt->libicb$v_bottom_of_stack)
+	break;
+      if (n >= skip_frames && (pc < exclude_min || pc > exclude_max))
+	{
+	  array[res++] = (void *)(ctxt->libicb$ih_pc);
+	  if (res == size)
+	    break;
+	}
+      n++;
+      LIB$I64_GET_PREV_INVO_CONTEXT (ctxt);
+    }
+
+  /* Free the context.  */
+  LIB$I64_FREE_INVO_CONTEXT (ctxt);
+  return res;
+}
diff --git a/gcc/ada/tracebak.c b/gcc/ada/tracebak.c
index 80d1a78..ba0381e 100644
--- a/gcc/ada/tracebak.c
+++ b/gcc/ada/tracebak.c
@@ -6,7 +6,7 @@
  *                                                                          *
  *                          C Implementation File                           *
  *                                                                          *
- *                     Copyright (C) 2000-2006, AdaCore                     *
+ *                     Copyright (C) 2000-2007, AdaCore                     *
  *                                                                          *
  * GNAT 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- *
@@ -97,7 +97,12 @@ extern void (*Unlock_Task) (void);
 
 #include "tb-alvms.c"
 
+#elif defined (__ia64__) && defined (__VMS__)
+
+#include "tb-ivms.c"
+
 #else
+
 /* No target specific implementation.  */
 
 /*----------------------------------------------------------------*