[vxworks 11/14] WTX-TCL support module.

[Joel Brobecker <brobecker at adacore dot com>]

For VxWorks 5.x and 653, we need to use the TCL extension in order to
access some of the information we are looking for (list of VxWorks
tasks running on the target, for instance).  This is only because
the WTX protocol does not provide access to this info.

2010-04-24  Joel Brobecker  <brobecker@adacore.com>

        * remote-wtx-tcl.c: New file.
---
 gdb/remote-wtx-tcl.c |  493 ++++++++++++++++++++++++++++++++++++++++++++++++++
 1 files changed, 493 insertions(+), 0 deletions(-)
 create mode 100644 gdb/remote-wtx-tcl.c

diff --git a/gdb/remote-wtx-tcl.c b/gdb/remote-wtx-tcl.c
new file mode 100644
index 0000000..760d20c
--- /dev/null
+++ b/gdb/remote-wtx-tcl.c
@@ -0,0 +1,493 @@
+/* Access to the TCL module in VxWorks systems.
+
+   Copyright 2007, 2010 Free Software Foundation, Inc.
+
+   This file is part of GDB.
+
+   This program is free software; you can redistribute it and/or modify
+   it under the terms of the GNU General Public License as published by
+   the Free Software Foundation; either version 3 of the License, or
+   (at your option) any later version.
+
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT 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
+   along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
+
+#include "defs.h"
+#include "command.h"
+#include "gdb_string.h"
+#include "remote-wtx-opt.h"
+#include "remote-wtxapi.h"
+#include "gdb_stat.h"
+#include "gdb_assert.h"
+#include "remote-wtx-pd.h"
+#include "remote-wtx-utils.h"
+
+/* Includes from the VxWorks install.  */
+#define HOST
+#include "tcl.h"
+#if WTX_PROT_VERSION != 4
+#include "wtxtcl.h"
+#endif
+
+/* Some functions provided by libwtxtcl that we use.  These are resolved
+   during this unit's initialization phase.  */
+static char * (*wtx_tcl_handle_grant) (Tcl_Interp *pInterp, HWTX hWtx);
+static int (*wtx_tcl_init) (Tcl_Interp *pInterp);
+
+/* Non-zero if the system provides support for computing the address
+   of the memory region where the FP registers are saved for each task.
+   Zero otherwise.  */
+static int tcb_has_fp_regs_p = 0;
+
+static Tcl_Interp *tcl_handle = NULL;
+
+/* Evaluate the given TCL expression (STR), and return non-zero if
+   successful.
+
+   When successful, then OUTPUT will contain the evaluation output.
+   When the evaluation fails, OUTPUT contains the error message.  */
+
+static int
+wtxtcl_eval (char *str, char **output)
+{
+  const int status = Tcl_Eval (tcl_handle, str);
+
+  if (tcl_handle->result != NULL)
+    *output = tcl_handle->result;
+  else
+    *output = "";
+
+  /* If the evaluation failed, and the user requested verbose TCL error
+     messages, then fetch the error message from the value of the "errorInfo"
+     variable instead of using the standard (short) error message.  */
+
+  if (status == TCL_ERROR && wtx_opt_tcl_verbose_p ())
+    *output = (char *) Tcl_GetVar (tcl_handle, "errorInfo", 0);
+
+  return (status != TCL_ERROR);
+}
+
+/* Evaluate the given TCL expression (STR), and return non-zero if
+   successful.
+
+   When successful, the evaluation output is printed on standard output.
+   Otherwise, the error message is printed on standard output.  */
+
+static int
+wtxtcl_eval_verbose (char *str)
+{
+  char *output;
+  const int success = wtxtcl_eval (str, &output);
+
+  if (success)
+    printf_filtered ("%s\n", output);
+  else
+    printf_filtered (_("TCL error: %s\n"), output);
+
+  return success;
+}
+
+/* Implement the "tcl" command.  */
+
+static void
+tcl_command (char *args, int from_tty)
+{
+  if (args == NULL)
+    return;
+
+  wtxtcl_eval_verbose (args);
+}
+
+/* Return the full path name of the "shell.tcl" TCL file that should
+   be part of the VxWorks system installation on the host.
+
+   Return NULL if the file could not be found.  */
+
+static const char *
+shell_tcl_fullpath (void)
+{
+  const char *base_dir;
+  static char *shell_tcl = NULL;
+  struct stat stat_info;
+
+  if (shell_tcl != NULL)
+    return shell_tcl;
+
+  /* First option:  See if we can find the shell.tcl file using
+     the WIND_BASE environment variable.  */
+
+  base_dir = getenv ("WIND_BASE");
+  if (base_dir != NULL)
+    {
+      shell_tcl = xstrprintf ("%s%shost%sresource%stcl%sshell.tcl",
+                              base_dir, SLASH_STRING, SLASH_STRING,
+                              SLASH_STRING, SLASH_STRING);
+
+      if (stat (shell_tcl, &stat_info) == 0)  /* Found it!  */
+        return shell_tcl;
+
+      xfree (shell_tcl);
+    }
+  
+  /* Second option: Try with the WIND_FOUNDATION_PATH environment variable
+     as the root install directory.  */
+
+  base_dir = getenv ("WIND_FOUNDATION_PATH");
+  if (base_dir != NULL)
+    {
+      shell_tcl =
+        xstrprintf ("%s%sresource%swindsh%svxWorks653%stcl%sshell.tcl",
+                    base_dir, SLASH_STRING, SLASH_STRING, SLASH_STRING,
+                    SLASH_STRING, SLASH_STRING);
+
+      if (stat (shell_tcl, &stat_info) == 0)  /* Found it!  */
+        return shell_tcl;
+
+      xfree (shell_tcl);
+    }
+  
+  /* Not found.  */
+
+  shell_tcl = NULL;
+  return shell_tcl;
+}
+
+/* Source a TCL script given its full path name.  */
+
+static int
+wtxtcl_source_file (const char *fullpath)
+{
+  char *source_expr = xstrprintf ("source %s", fullpath);
+  int success;
+
+  success = wtxtcl_eval_verbose (source_expr);
+  xfree (source_expr);
+  return success;
+}
+
+/* Initialize the TCL engine for use by GDB.  This should performed
+   after the debugger is connected to the target server.  */
+
+static void
+wtxtcl_initialize (HWTX wtx_handle)
+{
+  const char *shell_tcl = shell_tcl_fullpath ();
+  int success;
+
+  /* shell.tcl and shellInit are defined in every version of VxWorks;
+     so, if it cannot be found, loaded, or initialized, this should return
+     an error, not a warning.  */
+
+  if (shell_tcl == NULL)
+    error (_("Could not locate shell.tcl"));
+
+  /* Tell our TCL handle which WTX connection to use.  */
+  wtx_tcl_handle_grant (tcl_handle, wtx_handle);
+  
+  /* Source shell.tcl.  */
+  success = wtxtcl_source_file (shell_tcl);
+  if (!success)
+    error (_("Could not load shell.tcl"));
+
+  /* Evaluate the shellInit function from shell.tcl.  */
+  success = wtxtcl_eval_verbose ("shellInit");
+  if (!success)
+    error (_("Could not initialize shell.tcl "));
+}
+
+/* Implement the "get_task_pd" method of the wtxapi_support_ops vector.
+   (see remote-wtxapi.h for more details.  */
+
+static int
+wtxtcl_get_task_pd (int task_id, pd_id_t *task_pd)
+{
+  char *tcl_cmd;
+  char *task_info;
+  int success;
+  int j;
+
+  gdb_assert (task_pd != NULL);
+
+  /* If the system does not support partitions, then return the NULL_PD.  */
+
+  if (!wtx_pd_system_has_pds ())
+    {
+      *task_pd = NULL_PD;
+      return 1;
+    }
+
+  tcl_cmd = xstrprintf ("taskInfoGet 0x%x", task_id);
+  success = wtxtcl_eval (tcl_cmd, &task_info);
+
+  if (!success)  /* The task probably no longer exist...  */
+    return 0;
+
+  /* Skip the first 8 tokens and go directly to the 9th, which contains
+     the PD ID.  */
+  for (j = 0; j < 8; j++)
+    task_info = skip_space_delimited_token (task_info);
+
+  *task_pd = strtoul (task_info, NULL, 16);
+  return 1;
+}
+
+static struct wtxapi_thread_info *
+wtxtcl_get_thread_list (void)
+{
+  /* The gopher expression to be used on VxWorks 5.x (WTX version 2).  */
+  const char *wtx2_gopher_expr =
+    "[shSymAddr activeQHead] *"
+    "{"
+    "<"
+    "-$offset(WIND_TCB,activeNode) !"
+    "<+$offset(WIND_TCB,name) *$>"
+    "<+$offset(WIND_TCB,pStackBase) @>"
+    "<+$offset(WIND_TCB,pStackEnd) @>"
+    "<+$offset(WIND_TCB,regs) !>"
+    "<0 !>"  /* FP registers are not accessible on vxWorks 5.x.  */
+    ">"
+    "*"
+    "}";
+
+  /* The gopher expression to be used on VxWorks 653 (WTX versions 3 & 4).  */
+  const char *wtx3_gopher_expr =
+    "[shSymAddr taskClassId] *"
+    "+$offset(OBJ_CLASS,objList) *"
+    "{"
+    "<"
+    "-$offset(OBJ_CORE,classNode) !"
+    "<$objNameGopherString>"
+    "<+$offset(WIND_TCB,pStackBase) @>"
+    "<+$offset(WIND_TCB,pStackEnd) @>"
+    "<+$offset(WIND_TCB,regs) !>"
+    "<+$offset(WIND_TCB,pFpContext) * +$offset(FP_CONTEXT,fpr) !>"
+    "> "
+    "*"
+    "}";
+
+  /* The following expression is an expression that can be used on old
+     vxWorks 653 systems (WTX version 3 & 4) that do not provide
+     convenient access to the location of the FP registers in the TCB.
+     It is provided to remain compatible with those older systems, and
+     is identical to WTX3_GOPHER_EXPR except that zero is returned in
+     place of the FP register address.  */
+  const char *wtx3_gopher_expr_fallback =
+    "[shSymAddr taskClassId] *"
+    "+$offset(OBJ_CLASS,objList) *"
+    "{"
+    "<"
+    "-$offset(OBJ_CORE,classNode) !"
+    "<$objNameGopherString>"
+    "<+$offset(WIND_TCB,pStackBase) @>"
+    "<+$offset(WIND_TCB,pStackEnd) @>"
+    "<+$offset(WIND_TCB,regs) !>"
+    "<0 !>"
+    "> "
+    "*"
+    "}";
+
+  const char *gopher_expr;
+  char *tcl_expr;
+  char *tcl_output;
+  char *current_thread;
+  int success;
+  struct wtxapi_thread_info *thread_list_head = NULL;
+
+  /* Select the gopher expression that is appropriate for our system.  */
+
+  if (WTX_PROT_VERSION == 2)
+    gopher_expr = wtx2_gopher_expr;
+  else if (tcb_has_fp_regs_p)
+    gopher_expr = wtx3_gopher_expr;
+  else
+    gopher_expr = wtx3_gopher_expr_fallback;
+
+  /* Evaluate the gopher expression.  */
+
+  tcl_expr = xstrprintf ("wtxGopherEval \"%s\"", gopher_expr);
+  success = wtxtcl_eval (tcl_expr, &tcl_output);
+  xfree (tcl_expr);
+  
+  if (!success)
+    {
+      warning (_("Failed to get thread list, TCL returned: %s"), tcl_output);
+      return NULL;
+    }
+
+  /* Parse the result.  */
+
+  current_thread = skip_whitespaces (tcl_output);
+  while (current_thread && *current_thread != '\0')
+    {
+      struct wtxapi_thread_info *new_thread
+        = xmalloc (sizeof (struct wtxapi_thread_info));
+
+      /* Get the thread id.  */
+      new_thread->id = strtoul (current_thread, NULL, 0);
+      current_thread = skip_space_delimited_token (current_thread);
+
+      /* Get the thread name.  */
+      current_thread = skip_whitespaces (current_thread);
+      if (*current_thread == '{')
+        {
+          /* The thread name delimited by curly braces.  Find the
+             closing curly brace.  */
+          char *start = current_thread + 1;  /* skip the '{'...  */
+          char *end = skip_until_character (current_thread, '}');
+          char tmp = *end;
+
+          current_thread = end + 1;  /* discard the '}' marker.  */
+
+          *end = '\0';
+          new_thread->name = strdup (start);
+          *end = tmp;
+        }
+      else
+        current_thread = get_space_delimited_token (current_thread,
+                                                    &new_thread->name);
+
+      /* Skip the stack base and the stack end.  */
+      current_thread = skip_space_delimited_token (current_thread);
+      current_thread = skip_space_delimited_token (current_thread);
+
+      /* Get the address where the GP registers are stored.  */
+      new_thread->regs_addr = strtoul (current_thread, 0, 16);
+      current_thread = skip_space_delimited_token (current_thread);;
+
+      /* Get the address where the FP registers are stored.  */
+      new_thread->fp_regs_addr = strtoul (current_thread, 0, 16);
+      current_thread = skip_space_delimited_token (current_thread);;
+
+      /* Link in the new thread_info to our list.  */
+      new_thread->next = thread_list_head;
+      thread_list_head = new_thread;
+      
+      /* Advance to the begining of the next thread block.  */
+      current_thread = skip_whitespaces (current_thread);
+    }
+
+  return thread_list_head;
+}
+
+static WTX_CONTEXT_ID_T
+wtxtcl_system_mode_get_current_context_id (void)
+{
+  int success;
+  char *tcl_output;
+
+  success = wtxtcl_eval ("taskIdCurrent", &tcl_output);
+  if (!success)
+    error (_("taskIdCurrent failed: %s"), tcl_output);
+
+  return strtoul (tcl_output, NULL, 0);
+}
+
+static int
+wtxtcl_system_mode_support_p ()
+{
+  char *ignored;
+
+  /* Check to see if the system TCL script provide a couple of definitions
+     that we need in order to access the FP registers when in system mode.
+     These are not defined in old versions of VxWorks.
+     Warn the user of the consequences if the definitions are missing.  */
+  tcb_has_fp_regs_p =
+    (wtxtcl_eval ("return $offset(WIND_TCB,pFpContext)", &ignored)
+     && wtxtcl_eval ("return $offset(FP_CONTEXT,fpr)", &ignored));
+  if (!tcb_has_fp_regs_p)
+    warning (_("\
+system does not support access to the FP registers in system mode"));
+
+  return 1;
+}
+
+static struct wtxapi_support_ops wtxtcl_support_ops;
+
+static void
+initialize_wtx_support_ops ()
+{
+  wtxtcl_support_ops.wtx_connection_established_callback = wtxtcl_initialize;
+  wtxtcl_support_ops.get_thread_list = wtxtcl_get_thread_list;
+  wtxtcl_support_ops.get_task_pd = wtxtcl_get_task_pd;
+  wtxtcl_support_ops.system_mode_support_p = wtxtcl_system_mode_support_p;
+  wtxtcl_support_ops.system_mode_get_current_context_id =
+    wtxtcl_system_mode_get_current_context_id;
+}
+
+/* Search for SYM_NAME in the given library and return its address.
+   Throw an error if the symbol could not be found.  LIB is a non-NULL
+   handle on the library, as returned by load_shared_lib.  */
+static void *
+wtx_tcl_resolve (void *lib, char *sym_name)
+{
+  void *result = get_symbol_from_shared_lib (lib, sym_name);
+
+  if (!result)
+    error (_("Cannot find `%s' in WTX-TCL library"), sym_name);
+  return result;
+}
+
+/* Load all tcl-related libraries, and resolve all the addresses
+   of the functions we use from these libraries.  Throws an error
+   if anything wrong happens.  */
+static void
+load_wtx_tcl_libraries (void)
+{
+  void *lib = NULL;
+
+  if (WTX_PROT_VERSION == 4)
+    {
+      lib = load_shared_lib ("wtxtcl41");
+
+      if (!lib)
+	lib = load_shared_lib ("wtxtcl40");
+    }
+  else if (WTX_PROT_VERSION == 3)
+    {
+      lib = load_shared_lib ("wtxtcl30");
+    }
+  else if (WTX_PROT_VERSION == 2)
+    {
+      lib = load_shared_lib ("wtxtcl");
+    }
+
+  if (!lib)
+    error (_("Unable to load the wtxtcl library"));
+
+  wtx_tcl_init = wtx_tcl_resolve (lib, "wtxTclInit");
+  wtx_tcl_handle_grant = wtx_tcl_resolve (lib, "wtxTclHandleGrant");
+}
+
+void
+_initialize_remote_wtx_tcl (void)
+{
+  load_wtx_tcl_libraries ();
+
+  /* There seems to be a bug in the TCL library provided with PSC 2.x
+     which later causes "wtxTclInit" to crash unless we make the following
+     call to "Tcl_FindExecutable".  */
+  if (WTX_PROT_VERSION == 4)
+    Tcl_FindExecutable (NULL);
+
+  tcl_handle = Tcl_CreateInterp ();
+  if (tcl_handle == NULL)
+    error (_("Failed to initialize TCL module"));
+
+  /* Make the WTX routines accessible from TCL.  This is needed by
+     the TCL resource files that we will source later on, when we are
+     connected to the target server.  */
+  wtx_tcl_init (tcl_handle);
+
+  add_com ("tcl", class_obscure, tcl_command,
+           _("Evaluate the arguments with the TCL interpreter"));
+
+  /* Provide TCL-based support routine to the WTX module.  */
+  initialize_wtx_support_ops ();
+  wtxapi_set_support_ops (&wtxtcl_support_ops);
+}
+
-- 
1.6.3.3