gdb/gdbtk/generic/gdbtk-register.c

   1 /* Tcl/Tk command definitions for Insight - Registers
   2    Copyright (C) 2001, 2002, 2004, 2007 Free Software Foundation, Inc.
   3
   4    This file is part of GDB.
   5
   6    This program is free software; you can redistribute it and/or modify
   7    it under the terms of the GNU General Public License as published by
   8    the Free Software Foundation; either version 2 of the License, or
   9    (at your option) any later version.
  10
  11    This program is distributed in the hope that it will be useful,
  12    but WITHOUT ANY WARRANTY; without even the implied warranty of
  13    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14    GNU General Public License for more details.
  15
  16    You should have received a copy of the GNU General Public License
  17    along with this program; if not, write to the Free Software
  18    Foundation, Inc., 51 Franklin Street, Fifth Floor,
  19    Boston, MA 02110-1301, USA.  */
  20
  21 #include "defs.h"
  22 #include "frame.h"
  23 #include "regcache.h"
  24 #include "reggroups.h"
  25 #include "value.h"
  26 #include "target.h"
  27 #include "gdb_string.h"
  28 #include "language.h"
  29
  30 #include <tcl.h>
  31 #include "gdbtk.h"
  32 #include "gdbtk-cmds.h"
  33
  34 /* Argument passed to our register-mapping functions */
  35 typedef union
  36 {
  37   int integer;
  38   void *ptr;
  39 } map_arg;
  40
  41 /* Type of our mapping functions */
  42 typedef void (*map_func)(int, map_arg);
  43
  44 /* This contains the previous values of the registers, since the last call to
  45    gdb_changed_register_list.
  46
  47    It is an array of (NUM_REGS+NUM_PSEUDO_REGS)*MAX_REGISTER_RAW_SIZE bytes. */
  48
  49 static int gdb_register_info (ClientData, Tcl_Interp *, int, Tcl_Obj **);
  50 static void get_register (int, map_arg);
  51 static void get_register_name (int, map_arg);
  52 static void get_register_size (int, map_arg);
  53 static int map_arg_registers (Tcl_Interp *, int, Tcl_Obj **,
  54                               map_func, map_arg);
  55 static void register_changed_p (int, map_arg);
  56 static void setup_architecture_data (void);
  57 static int gdb_regformat (ClientData, Tcl_Interp *, int, Tcl_Obj **);
  58 static int gdb_reggroup (ClientData, Tcl_Interp *, int, Tcl_Obj **);
  59 static int gdb_reggrouplist (ClientData, Tcl_Interp *, int, Tcl_Obj **);
  60
  61 static void get_register_types (int regnum, map_arg);
  62
  63 static char *old_regs = NULL;
  64 static int *regformat = (int *)NULL;
  65 static struct type **regtype = (struct type **)NULL;
  66
  67 int
  68 Gdbtk_Register_Init (Tcl_Interp *interp)
  69 {
  70   Tcl_CreateObjCommand (interp, "gdb_reginfo", gdbtk_call_wrapper,
  71                         gdb_register_info, NULL);
  72   Tcl_CreateObjCommand (interp, "gdb_reg_arch_changed", gdbtk_call_wrapper,
  73                         setup_architecture_data, NULL);
  74
  75   /* Register/initialize any architecture specific data */
  76   setup_architecture_data ();
  77
  78   return TCL_OK;
  79 }
  80
  81 /* This implements the tcl command "gdb_reginfo".
  82  * It returns the requested information about registers.
  83  *
  84  * Tcl Arguments:
  85  *    OPTION    - "changed", "name", "size", "value" (see below)
  86  *    REGNUM(S) - the register(s) for which info is requested
  87  *
  88  * Tcl Result:
  89  *    The requested information
  90  *
  91  * Options:
  92  * changed
  93  *    Returns a list of registers whose values have changed since the
  94  *    last time the proc was called.
  95  *
  96  *    usage: gdb_reginfo changed [regnum0, ..., regnumN]
  97  *
  98  * name
  99  *    Return a list containing the names of the registers whose numbers
 100  *    are given by REGNUM ... .  If no register numbers are given, return
 101  *    all the registers' names.
 102  *
 103  *    usage: gdb_reginfo name [-numbers] [regnum0, ..., regnumN]
 104  *
 105  *    Note that some processors have gaps in the register numberings:
 106  *    even if there is no register numbered N, there may still be a
 107  *    register numbered N+1.  So if you call gdb_regnames with no
 108  *    arguments, you can't assume that the N'th element of the result is
 109  *    register number N.
 110  *
 111  *    Given the -numbers option, gdb_regnames returns, not a list of names,
 112  *    but a list of pairs {NAME NUMBER}, where NAME is the register name,
 113  *    and NUMBER is its number.
 114  *
 115  * size
 116  *    Returns the raw size of the register(s) in bytes.
 117  *
 118  *    usage: gdb_reginfo size [regnum0, ..., regnumN]
 119  *
 120  * value
 121  *    Returns a list of register values.
 122  *
 123  *    usage: gdb_reginfo value [regnum0, ..., regnumN]
 124  */
 125 static int
 126 gdb_register_info (ClientData clientData, Tcl_Interp *interp, int objc,
 127                    Tcl_Obj **objv)
 128 {
 129   int index;
 130   map_arg arg;
 131   map_func func;
 132   static const char *commands[] = {"changed", "name", "size", "value", "type",
 133                              "format", "group", "grouplist", NULL};
 134   enum commands_enum { REGINFO_CHANGED, REGINFO_NAME, REGINFO_SIZE, REGINFO_VALUE,
 135                        REGINFO_TYPE, REGINFO_FORMAT, REGINFO_GROUP, REGINFO_GROUPLIST };
 136
 137   if (objc < 2)
 138     {
 139       Tcl_WrongNumArgs (interp, 1, objv, "name|size|value|type|format|groups [regnum1 ... regnumN]");
 140       return TCL_ERROR;
 141     }
 142
 143   if (Tcl_GetIndexFromObj (interp, objv[1], commands, "options", 0,
 144                            &index) != TCL_OK)
 145     {
 146       result_ptr->flags |= GDBTK_IN_TCL_RESULT;
 147       return TCL_ERROR;
 148     }
 149
 150   /* Skip the option */
 151   objc -= 2;
 152   objv += 2;
 153
 154   switch ((enum commands_enum) index)
 155     {
 156     case REGINFO_CHANGED:
 157       func = register_changed_p;
 158       arg.ptr = NULL;
 159       break;
 160
 161     case REGINFO_NAME:
 162       {
 163         int len;
 164         char *s = Tcl_GetStringFromObj (objv[0], &len);
 165         if (objc != 0 && strncmp (s, "-numbers", len) == 0)
 166           {
 167             arg.integer = 1;
 168             objc--;
 169             objv++;
 170           }
 171         else
 172           arg.ptr = NULL;
 173
 174         func = get_register_name;
 175       }
 176       break;
 177
 178     case REGINFO_SIZE:
 179       func = get_register_size;
 180       arg.ptr = NULL;
 181       break;
 182
 183     case REGINFO_VALUE:
 184       func = get_register;
 185       arg.ptr = NULL;
 186       break;
 187
 188     case REGINFO_TYPE:
 189       func = get_register_types;
 190       arg.ptr = NULL;
 191       break;
 192
 193     case REGINFO_FORMAT:
 194       return gdb_regformat (clientData, interp, objc, objv);
 195
 196     case REGINFO_GROUP:
 197       return gdb_reggroup (clientData, interp, objc, objv);
 198
 199     case REGINFO_GROUPLIST:
 200       return gdb_reggrouplist (clientData, interp, objc, objv);
 201
 202     default:
 203       return TCL_ERROR;
 204     }
 205
 206   return map_arg_registers (interp, objc, objv, func, arg);
 207 }
 208
 209 static void
 210 get_register_size (int regnum, map_arg arg)
 211 {
 212   Tcl_ListObjAppendElement (gdbtk_interp, result_ptr->obj_ptr,
 213                             Tcl_NewIntObj (register_size (current_gdbarch, regnum)));
 214 }
 215
 216 /* returns a list of valid types for a register */
 217 /* Normally this will be only one type, except for SIMD and other */
 218 /* special registers. */
 219
 220 static void
 221 get_register_types (int regnum, map_arg arg)
 222 {
 223   struct type *reg_vtype;
 224   int i,n;
 225
 226   reg_vtype = register_type (current_gdbarch, regnum);
 227
 228   if (TYPE_CODE (reg_vtype) == TYPE_CODE_UNION)
 229     {
 230       n = TYPE_NFIELDS (reg_vtype);
 231       /* limit to 16 types */
 232       if (n > 16)
 233         n = 16;
 234
 235       for (i = 0; i < n; i++)
 236         {
 237           Tcl_Obj *ar[3], *list;
 238           char *buff;
 239           xasprintf (&buff, "%lx", (long)TYPE_FIELD_TYPE (reg_vtype, i));
 240           ar[0] = Tcl_NewStringObj (TYPE_FIELD_NAME (reg_vtype, i), -1);
 241           ar[1] = Tcl_NewStringObj (buff, -1);
 242           if (TYPE_CODE (TYPE_FIELD_TYPE (reg_vtype, i)) == TYPE_CODE_FLT)
 243             ar[2] = Tcl_NewStringObj ("float", -1);
 244           else
 245             ar[2] = Tcl_NewStringObj ("int", -1);
 246           list = Tcl_NewListObj (3, ar);
 247           Tcl_ListObjAppendElement (gdbtk_interp, result_ptr->obj_ptr, list);
 248           xfree (buff);
 249         }
 250     }
 251   else
 252     {
 253       Tcl_Obj *ar[3], *list;
 254       char *buff;
 255       xasprintf (&buff, "%lx", (long)reg_vtype);
 256       ar[0] = Tcl_NewStringObj (TYPE_NAME(reg_vtype), -1);
 257       ar[1] = Tcl_NewStringObj (buff, -1);
 258       if (TYPE_CODE (reg_vtype) == TYPE_CODE_FLT)
 259         ar[2] = Tcl_NewStringObj ("float", -1);
 260       else
 261         ar[2] = Tcl_NewStringObj ("int", -1);
 262       list = Tcl_NewListObj (3, ar);
 263       xfree (buff);
 264       Tcl_ListObjAppendElement (gdbtk_interp, result_ptr->obj_ptr, list);
 265     }
 266 }
 267
 268
 269 static void
 270 get_register (int regnum, map_arg arg)
 271 {
 272   int realnum;
 273   CORE_ADDR addr;
 274   enum lval_type lval;
 275   struct type *reg_vtype;
 276   gdb_byte buffer[MAX_REGISTER_SIZE];
 277   int optim, format;
 278   struct cleanup *old_chain = NULL;
 279   struct ui_file *stb;
 280   long dummy;
 281   char *res;
 282
 283   format = regformat[regnum];
 284   if (format == 0)
 285     format = 'x';
 286
 287   reg_vtype = regtype[regnum];
 288   if (reg_vtype == NULL)
 289     reg_vtype = register_type (current_gdbarch, regnum);
 290
 291   if (!target_has_registers)
 292     {
 293       if (result_ptr->flags & GDBTK_MAKES_LIST)
 294         Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewStringObj ("", -1));
 295       else
 296         Tcl_SetStringObj (result_ptr->obj_ptr, "", -1);
 297       return;
 298     }
 299
 300   frame_register (get_selected_frame (NULL), regnum, &optim, &lval,
 301                   &addr, &realnum, buffer);
 302
 303   if (optim)
 304     {
 305       Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
 306                                 Tcl_NewStringObj ("Optimized out", -1));
 307       return;
 308     }
 309
 310   stb = mem_fileopen ();
 311   old_chain = make_cleanup_ui_file_delete (stb);
 312
 313   if (format == 'r')
 314     {
 315       /* shouldn't happen. raw format is deprecated */
 316       int j;
 317       char *ptr, buf[1024];
 318
 319       strcpy (buf, "0x");
 320       ptr = buf + 2;
 321       for (j = 0; j < register_size (current_gdbarch, regnum); j++)
 322         {
 323           int idx = ((gdbarch_byte_order (current_gdbarch) == BFD_ENDIAN_BIG)
 324                      ? j : register_size (current_gdbarch, regnum) - 1 - j);
 325           sprintf (ptr, "%02x", (unsigned char) buffer[idx]);
 326           ptr += 2;
 327         }
 328       fputs_unfiltered (buf, stb);
 329     }
 330   else
 331     {
 332       if ((TYPE_CODE (reg_vtype) == TYPE_CODE_UNION)
 333           && (strcmp (FIELD_NAME (TYPE_FIELD (reg_vtype, 0)),
 334                       gdbarch_register_name (current_gdbarch, regnum)) == 0))
 335         {
 336           val_print (FIELD_TYPE (TYPE_FIELD (reg_vtype, 0)), buffer, 0, 0,
 337                      stb, format, 1, 0, Val_pretty_default, current_language);
 338         }
 339       else
 340         val_print (reg_vtype, buffer, 0, 0,
 341                    stb, format, 1, 0, Val_pretty_default, current_language);
 342     }
 343
 344   res = ui_file_xstrdup (stb, &dummy);
 345
 346   if (result_ptr->flags & GDBTK_MAKES_LIST)
 347     Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewStringObj (res, -1));
 348   else
 349     Tcl_SetStringObj (result_ptr->obj_ptr, res, -1);
 350
 351   xfree (res);
 352   do_cleanups (old_chain);
 353 }
 354
 355 static void
 356 get_register_name (int regnum, map_arg arg)
 357 {
 358   /* Non-zero if the caller wants the register numbers, too.  */
 359   int numbers = arg.integer;
 360   Tcl_Obj *name
 361     = Tcl_NewStringObj (gdbarch_register_name (current_gdbarch, regnum), -1);
 362   Tcl_Obj *elt;
 363
 364   if (numbers)
 365     {
 366       /* Build a tuple of the form "{REGNAME NUMBER}", and append it to
 367          our result.  */
 368       Tcl_Obj *array[2];
 369
 370       array[0] = name;
 371       array[1] = Tcl_NewIntObj (regnum);
 372       elt = Tcl_NewListObj (2, array);
 373     }
 374   else
 375     elt = name;
 376
 377   Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, elt);
 378 }
 379
 380 /* This is a sort of mapcar function for operations on registers */
 381
 382 static int
 383 map_arg_registers (Tcl_Interp *interp, int objc, Tcl_Obj **objv,
 384                    map_func func, map_arg arg)
 385 {
 386   int regnum, numregs;
 387
 388   /* Note that the test for a valid register must include checking the
 389      gdbarch_register_name because gdbarch_num_regs may be allocated for
 390      the union of the register sets within a family of related processors.
 391      In this case, some entries of gdbarch_register_name will change
 392      depending upon the particular processor being debugged.  */
 393
 394   numregs = (gdbarch_num_regs (current_gdbarch)
 395              + gdbarch_num_pseudo_regs (current_gdbarch));
 396
 397   if (objc == 0)                /* No args, just do all the regs */
 398     {
 399       result_ptr->flags |= GDBTK_MAKES_LIST;
 400       for (regnum = 0; regnum < numregs; regnum++)
 401         {
 402           if (gdbarch_register_name (current_gdbarch, regnum) == NULL
 403               || *(gdbarch_register_name (current_gdbarch, regnum)) == '\0')
 404             continue;
 405           func (regnum, arg);
 406         }
 407       return TCL_OK;
 408     }
 409
 410   if (objc == 1)
 411     if (Tcl_ListObjGetElements (interp, *objv, &objc, &objv ) != TCL_OK)
 412       return TCL_ERROR;
 413
 414   if (objc > 1)
 415     result_ptr->flags |= GDBTK_MAKES_LIST;
 416
 417   /* Else, list of register #s, just do listed regs */
 418   for (; objc > 0; objc--, objv++)
 419     {
 420       if (Tcl_GetIntFromObj (NULL, *objv, &regnum) != TCL_OK)
 421         {
 422           result_ptr->flags |= GDBTK_IN_TCL_RESULT;
 423           return TCL_ERROR;
 424         }
 425
 426       if (regnum >= 0  && regnum < numregs)
 427         func (regnum, arg);
 428       else
 429         {
 430           Tcl_SetStringObj (result_ptr->obj_ptr, "bad register number", -1);
 431           return TCL_ERROR;
 432         }
 433     }
 434   return TCL_OK;
 435 }
 436
 437 static void
 438 register_changed_p (int regnum, map_arg arg)
 439 {
 440   char raw_buffer[MAX_REGISTER_SIZE];
 441
 442   if (!target_has_registers
 443       || !frame_register_read (get_selected_frame (NULL), regnum, raw_buffer))
 444     return;
 445
 446   if (memcmp (&old_regs[regnum * MAX_REGISTER_SIZE], raw_buffer,
 447               register_size (current_gdbarch, regnum)) == 0)
 448     return;
 449
 450   /* Found a changed register.  Save new value and return its number. */
 451
 452   memcpy (&old_regs[regnum * MAX_REGISTER_SIZE], raw_buffer,
 453           register_size (current_gdbarch, regnum));
 454
 455   Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewIntObj (regnum));
 456 }
 457
 458 static void
 459 setup_architecture_data ()
 460 {
 461   int numregs;
 462
 463   xfree (old_regs);
 464   xfree (regformat);
 465   xfree (regtype);
 466
 467   numregs = (gdbarch_num_regs (current_gdbarch)
 468              + gdbarch_num_pseudo_regs (current_gdbarch));
 469   old_regs = xcalloc (1, numregs * MAX_REGISTER_SIZE + 1);
 470   regformat = (int *)xcalloc (numregs, sizeof(int));
 471   regtype = (struct type **)xcalloc (numregs, sizeof(struct type **));
 472 }
 473
 474 /* gdb_regformat sets the format for a register */
 475 /* This is necessary to allow "gdb_reginfo value" to return a list */
 476 /* of registers and values. */
 477 /* Usage: gdb_reginfo format regno typeaddr format */
 478
 479 static int
 480 gdb_regformat (ClientData clientData, Tcl_Interp *interp,
 481                int objc, Tcl_Obj **objv)
 482 {
 483   int fm, regno, numregs;
 484   struct type *type;
 485
 486   if (objc != 3)
 487     {
 488       Tcl_WrongNumArgs (interp, 0, objv, "gdb_reginfo regno type format");
 489       return TCL_ERROR;
 490     }
 491
 492   if (Tcl_GetIntFromObj (interp, objv[0], &regno) != TCL_OK)
 493     return TCL_ERROR;
 494
 495   type = (struct type *)strtol (Tcl_GetStringFromObj (objv[1], NULL), NULL, 16);
 496   fm = (int)*(Tcl_GetStringFromObj (objv[2], NULL));
 497
 498   numregs = (gdbarch_num_regs (current_gdbarch)
 499              + gdbarch_num_pseudo_regs (current_gdbarch));
 500   if (regno >= numregs)
 501     {
 502       gdbtk_set_result (interp, "Register number %d too large", regno);
 503       return TCL_ERROR;
 504     }
 505
 506   regformat[regno] = fm;
 507   regtype[regno] = type;
 508
 509   return TCL_OK;
 510 }
 511
 512
 513 /* gdb_reggrouplist returns the names of the register groups */
 514 /* for the current architecture. */
 515 /* Usage: gdb_reginfo groups */
 516
 517 static int
 518 gdb_reggrouplist (ClientData clientData, Tcl_Interp *interp,
 519                   int objc, Tcl_Obj **objv)
 520 {
 521   struct reggroup *group;
 522   int i = 0;
 523
 524   if (objc != 0)
 525     {
 526       Tcl_WrongNumArgs (interp, 0, objv, "gdb_reginfo grouplist");
 527       return TCL_ERROR;
 528     }
 529
 530   for (group = reggroup_next (current_gdbarch, NULL);
 531        group != NULL;
 532        group = reggroup_next (current_gdbarch, group))
 533     {
 534       if (reggroup_type (group) == USER_REGGROUP)
 535         Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewStringObj (reggroup_name (group), -1));
 536     }
 537   return TCL_OK;
 538 }
 539
 540
 541 /* gdb_reggroup returns the names of the registers in a group. */
 542 /* Usage: gdb_reginfo group groupname */
 543
 544 static int
 545 gdb_reggroup (ClientData clientData, Tcl_Interp *interp,
 546               int objc, Tcl_Obj **objv)
 547 {
 548   struct reggroup *group;
 549   char *groupname;
 550   int regnum, num;
 551
 552   if (objc != 1)
 553     {
 554       Tcl_WrongNumArgs (interp, 0, objv, "gdb_reginfo group groupname");
 555       return TCL_ERROR;
 556     }
 557
 558   groupname = Tcl_GetStringFromObj (objv[0], NULL);
 559   if (groupname == NULL)
 560     {
 561       gdbtk_set_result (interp, "could not read groupname");
 562       return TCL_ERROR;
 563     }
 564
 565   for (group = reggroup_next (current_gdbarch, NULL);
 566        group != NULL;
 567        group = reggroup_next (current_gdbarch, group))
 568     {
 569       if (strcmp (groupname, reggroup_name (group)) == 0)
 570         break;
 571     }
 572
 573   if (group == NULL)
 574     return TCL_ERROR;
 575
 576   num = (gdbarch_num_regs (current_gdbarch)
 577          + gdbarch_num_pseudo_regs (current_gdbarch));
 578   for (regnum = 0; regnum < num; regnum++)
 579     {
 580       if (gdbarch_register_reggroup_p (current_gdbarch, regnum, group))
 581         Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewIntObj (regnum));
 582     }
 583   return TCL_OK;
 584 }
 585