[VxWorks 16/20] 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.

gdb/ChangeLog:

        * remote-wtx-tcl.c: New file.
---
 gdb/remote-wtx-tcl.c |  550 ++++++++++++++++++++++++++++++++++++++++++++++++++
 1 files changed, 550 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..324ce2c
--- /dev/null
+++ b/gdb/remote-wtx-tcl.c
@@ -0,0 +1,550 @@
+/* Access to the TCL module in VxWorks systems.
+
+   Copyright 2007, 2010, 2011 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"
+#include "cli/cli-utils.h"
+#include "cli/cli-cmds.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);
+static int (*tcl_eval) (Tcl_Interp *interp, const char *script);
+static char * (*tcl_get_var) (Tcl_Interp *interp, const char *var_name,
+			      int flags);
+static int (*tcl_find_executable) (const char * argv0);
+static Tcl_Interp * (*tcl_create_interp) ();
+static int (*tcl_splitlist) (Tcl_Interp *interp, char *list, int *argcPtr,
+			     const char ***argvPtr);
+static void (*tcl_free) (char *ptr);
+
+/* 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;
+
+/* Same as calling Tcl_SplitList, except that it raises an error if
+   the parsing fails.  The parsing failure is really highly unlikely,
+   and should only happen when something completely wrong happened
+   somewhere.  */
+
+static void
+wtxtcl_split_list (char *str, int *argc, const char ***argv)
+{
+  int code;
+
+  code = tcl_splitlist (tcl_handle, str, argc, argv);
+  if (code != TCL_OK)
+    error (_("failed to split list: '%s'"), str);
+}
+
+/* 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_get_var (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
+maintenance_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;
+  int argc;
+  const char **argv;
+
+  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);
+  xfree (tcl_cmd);
+
+  if (!success)  /* The task probably no longer exist...  */
+    return 0;
+
+  /* The PD ID is the 9th token of the list.  */
+  wtxtcl_split_list (task_info, &argc, &argv);
+  if (argc < 9)
+    error (_("Invalid taskInfoGet output, not enough tokens (%d):\n%s"),
+           argc, task_info);
+  *task_pd = strtoul (argv[8], NULL, 16);
+  tcl_free ((char *) argv); /* The cast is as per the Tcl documentation.  */
+
+  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;
+  int success;
+  struct wtxapi_thread_info *thread_list_head = NULL;
+  int argc;
+  const char **argv;
+  int i;
+
+  /* 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.  */
+
+  wtxtcl_split_list (tcl_output, &argc, &argv);
+
+  /* For each thread, there should be 6 tokens.  So if the number
+     of elements in argv is not a multiple of 6, the output is
+     malformed.  */
+  if (argc % 6 != 0)
+    {
+      warning (_("Failed to parse thread list, "
+                 "invalid number of elements (%d):\n%s"),
+	       argc, tcl_output);
+      tcl_free ((char *) argv);
+      return NULL;
+    }
+
+  for (i = 0; i < argc / 6; i++)
+    {
+      struct wtxapi_thread_info *new_thread
+        = xmalloc (sizeof (struct wtxapi_thread_info));
+
+      new_thread->id = strtoul (argv[i * 6], NULL, 0);
+      new_thread->name = xstrdup (argv[i * 6 + 1]);
+      new_thread->regs_addr = strtoul (argv[i * 6 + 4], 0, 16);
+      new_thread->fp_regs_addr = strtoul (argv[i * 6 + 5], 0, 16);
+
+      /* Link in the new thread_info to our list.  */
+      new_thread->next = thread_list_head;
+      thread_list_head = new_thread;
+    }
+
+  tcl_free ((char *) argv);
+
+  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;
+
+  /* Load tcl libraries.  These have a different name on unix and
+     win32; e.g. libtcl8.5 on unix would be libtcl85 on win32.  */
+
+  if (WTX_PROT_VERSION == 4)
+    {
+      /* WTX 4.0 uses tcl 8.4; WTX 4.1 uses tcl 8.5.  */
+
+      lib = load_shared_lib ("tcl85");
+
+      if (!lib)
+	lib = load_shared_lib ("tcl8.5");
+
+      if (!lib)
+	lib = load_shared_lib ("tcl84");
+
+      if (!lib)
+	lib = load_shared_lib ("tcl8.4");
+    }
+  else
+    {
+      /* WTX 2 and 3 are both based on tcl 8.0.  */
+
+      lib = load_shared_lib ("tcl80");
+
+      if (!lib)
+	lib = load_shared_lib ("tcl8.0");
+
+      if (!lib)
+	lib = load_shared_lib ("tcl");	
+    }
+
+  if (!lib)
+    error (_("Unable to load the tcl library"));
+
+  tcl_eval = wtx_tcl_resolve (lib, "Tcl_Eval");
+  tcl_get_var = wtx_tcl_resolve (lib, "Tcl_GetVar");
+  tcl_find_executable = wtx_tcl_resolve (lib, "Tcl_FindExecutable");
+  tcl_create_interp = wtx_tcl_resolve (lib, "Tcl_CreateInterp");
+  tcl_splitlist = wtx_tcl_resolve (lib, "Tcl_SplitList");
+  tcl_free = wtx_tcl_resolve (lib, "Tcl_Free");
+
+  /* Then load WTX Tcl libraries.  */
+
+  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_find_executable (NULL);
+
+  tcl_handle = tcl_create_interp ();
+  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_cmd ("tcl", class_maintenance, maintenance_tcl_command,
+           _("Evaluate the arguments with the TCL interpreter"),
+	   &maintenancelist);
+
+  /* Provide TCL-based support routine to the WTX module.  */
+  initialize_wtx_support_ops ();
+  wtxapi_set_support_ops (&wtxtcl_support_ops);
+}
+
-- 
1.7.0.4