gdb/guile/scm-progspace.c

   1 /* Guile interface to program spaces.
   2
   3    Copyright (C) 2010-2021 Free Software Foundation, Inc.
   4
   5    This file is part of GDB.
   6
   7    This program is free software; you can redistribute it and/or modify
   8    it under the terms of the GNU General Public License as published by
   9    the Free Software Foundation; either version 3 of the License, or
  10    (at your option) any later version.
  11
  12    This program is distributed in the hope that it will be useful,
  13    but WITHOUT ANY WARRANTY; without even the implied warranty of
  14    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15    GNU General Public License for more details.
  16
  17    You should have received a copy of the GNU General Public License
  18    along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
  19
  20 #include "defs.h"
  21 #include "charset.h"
  22 #include "progspace.h"
  23 #include "objfiles.h"
  24 #include "language.h"
  25 #include "arch-utils.h"
  26 #include "guile-internal.h"
  27
  28 /* NOTE: Python exports the name "Progspace", so we export "progspace".
  29    Internally we shorten that to "pspace".  */
  30
  31 /* The <gdb:progspace> smob.  */
  32
  33 struct pspace_smob
  34 {
  35   /* This always appears first.  */
  36   gdb_smob base;
  37
  38   /* The corresponding pspace.  */
  39   struct program_space *pspace;
  40
  41   /* The pretty-printer list of functions.  */
  42   SCM pretty_printers;
  43
  44   /* The <gdb:progspace> object we are contained in, needed to
  45      protect/unprotect the object since a reference to it comes from
  46      non-gc-managed space (the progspace).  */
  47   SCM containing_scm;
  48 };
  49
  50 static const char pspace_smob_name[] = "gdb:progspace";
  51
  52 /* The tag Guile knows the pspace smob by.  */
  53 static scm_t_bits pspace_smob_tag;
  54
  55 static const struct program_space_data *psscm_pspace_data_key;
  56
  57 /* Return the list of pretty-printers registered with P_SMOB.  */
  58
  59 SCM
  60 psscm_pspace_smob_pretty_printers (const pspace_smob *p_smob)
  61 {
  62   return p_smob->pretty_printers;
  63 }
  64 \f
  65 /* Administrivia for progspace smobs.  */
  66
  67 /* The smob "print" function for <gdb:progspace>.  */
  68
  69 static int
  70 psscm_print_pspace_smob (SCM self, SCM port, scm_print_state *pstate)
  71 {
  72   pspace_smob *p_smob = (pspace_smob *) SCM_SMOB_DATA (self);
  73
  74   gdbscm_printf (port, "#<%s ", pspace_smob_name);
  75   if (p_smob->pspace != NULL)
  76     {
  77       struct objfile *objfile = p_smob->pspace->symfile_object_file;
  78
  79       gdbscm_printf (port, "%s",
  80                      objfile != NULL
  81                      ? objfile_name (objfile)
  82                      : "{no symfile}");
  83     }
  84   else
  85     scm_puts ("{invalid}", port);
  86   scm_puts (">", port);
  87
  88   scm_remember_upto_here_1 (self);
  89
  90   /* Non-zero means success.  */
  91   return 1;
  92 }
  93
  94 /* Low level routine to create a <gdb:progspace> object.
  95    It's empty in the sense that a progspace still needs to be associated
  96    with it.  */
  97
  98 static SCM
  99 psscm_make_pspace_smob (void)
 100 {
 101   pspace_smob *p_smob = (pspace_smob *)
 102     scm_gc_malloc (sizeof (pspace_smob), pspace_smob_name);
 103   SCM p_scm;
 104
 105   p_smob->pspace = NULL;
 106   p_smob->pretty_printers = SCM_EOL;
 107   p_scm = scm_new_smob (pspace_smob_tag, (scm_t_bits) p_smob);
 108   p_smob->containing_scm = p_scm;
 109   gdbscm_init_gsmob (&p_smob->base);
 110
 111   return p_scm;
 112 }
 113
 114 /* Clear the progspace pointer in P_SMOB and unprotect the object from GC.  */
 115
 116 static void
 117 psscm_release_pspace (pspace_smob *p_smob)
 118 {
 119   p_smob->pspace = NULL;
 120   scm_gc_unprotect_object (p_smob->containing_scm);
 121 }
 122
 123 /* Progspace registry cleanup handler for when a progspace is deleted.  */
 124
 125 static void
 126 psscm_handle_pspace_deleted (struct program_space *pspace, void *datum)
 127 {
 128   pspace_smob *p_smob = (pspace_smob *) datum;
 129
 130   gdb_assert (p_smob->pspace == pspace);
 131
 132   psscm_release_pspace (p_smob);
 133 }
 134
 135 /* Return non-zero if SCM is a <gdb:progspace> object.  */
 136
 137 static int
 138 psscm_is_pspace (SCM scm)
 139 {
 140   return SCM_SMOB_PREDICATE (pspace_smob_tag, scm);
 141 }
 142
 143 /* (progspace? object) -> boolean */
 144
 145 static SCM
 146 gdbscm_progspace_p (SCM scm)
 147 {
 148   return scm_from_bool (psscm_is_pspace (scm));
 149 }
 150
 151 /* Return a pointer to the progspace_smob that encapsulates PSPACE,
 152    creating one if necessary.
 153    The result is cached so that we have only one copy per objfile.  */
 154
 155 pspace_smob *
 156 psscm_pspace_smob_from_pspace (struct program_space *pspace)
 157 {
 158   pspace_smob *p_smob;
 159
 160   p_smob = (pspace_smob *) program_space_data (pspace, psscm_pspace_data_key);
 161   if (p_smob == NULL)
 162     {
 163       SCM p_scm = psscm_make_pspace_smob ();
 164
 165       p_smob = (pspace_smob *) SCM_SMOB_DATA (p_scm);
 166       p_smob->pspace = pspace;
 167
 168       set_program_space_data (pspace, psscm_pspace_data_key, p_smob);
 169       scm_gc_protect_object (p_smob->containing_scm);
 170     }
 171
 172   return p_smob;
 173 }
 174
 175 /* Return the <gdb:progspace> object that encapsulates PSPACE.  */
 176
 177 SCM
 178 psscm_scm_from_pspace (struct program_space *pspace)
 179 {
 180   pspace_smob *p_smob = psscm_pspace_smob_from_pspace (pspace);
 181
 182   return p_smob->containing_scm;
 183 }
 184
 185 /* Returns the <gdb:progspace> object in SELF.
 186    Throws an exception if SELF is not a <gdb:progspace> object.  */
 187
 188 static SCM
 189 psscm_get_pspace_arg_unsafe (SCM self, int arg_pos, const char *func_name)
 190 {
 191   SCM_ASSERT_TYPE (psscm_is_pspace (self), self, arg_pos, func_name,
 192                    pspace_smob_name);
 193
 194   return self;
 195 }
 196
 197 /* Returns a pointer to the pspace smob of SELF.
 198    Throws an exception if SELF is not a <gdb:progspace> object.  */
 199
 200 static pspace_smob *
 201 psscm_get_pspace_smob_arg_unsafe (SCM self, int arg_pos,
 202                                   const char *func_name)
 203 {
 204   SCM p_scm = psscm_get_pspace_arg_unsafe (self, arg_pos, func_name);
 205   pspace_smob *p_smob = (pspace_smob *) SCM_SMOB_DATA (p_scm);
 206
 207   return p_smob;
 208 }
 209
 210 /* Return non-zero if pspace P_SMOB is valid.  */
 211
 212 static int
 213 psscm_is_valid (pspace_smob *p_smob)
 214 {
 215   return p_smob->pspace != NULL;
 216 }
 217
 218 /* Return the pspace smob in SELF, verifying it's valid.
 219    Throws an exception if SELF is not a <gdb:progspace> object or is
 220    invalid.  */
 221
 222 static pspace_smob *
 223 psscm_get_valid_pspace_smob_arg_unsafe (SCM self, int arg_pos,
 224                                         const char *func_name)
 225 {
 226   pspace_smob *p_smob
 227     = psscm_get_pspace_smob_arg_unsafe (self, arg_pos, func_name);
 228
 229   if (!psscm_is_valid (p_smob))
 230     {
 231       gdbscm_invalid_object_error (func_name, arg_pos, self,
 232                                    _("<gdb:progspace>"));
 233     }
 234
 235   return p_smob;
 236 }
 237 \f
 238 /* Program space methods.  */
 239
 240 /* (progspace-valid? <gdb:progspace>) -> boolean
 241    Returns #t if this program space still exists in GDB.  */
 242
 243 static SCM
 244 gdbscm_progspace_valid_p (SCM self)
 245 {
 246   pspace_smob *p_smob
 247     = psscm_get_pspace_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 248
 249   return scm_from_bool (p_smob->pspace != NULL);
 250 }
 251
 252 /* (progspace-filename <gdb:progspace>) -> string
 253    Returns the name of the main symfile associated with the progspace,
 254    or #f if there isn't one.
 255    Throw's an exception if the underlying pspace is invalid.  */
 256
 257 static SCM
 258 gdbscm_progspace_filename (SCM self)
 259 {
 260   pspace_smob *p_smob
 261     = psscm_get_valid_pspace_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 262   struct objfile *objfile = p_smob->pspace->symfile_object_file;
 263
 264   if (objfile != NULL)
 265     return gdbscm_scm_from_c_string (objfile_name (objfile));
 266   return SCM_BOOL_F;
 267 }
 268
 269 /* (progspace-objfiles <gdb:progspace>) -> list
 270    Return the list of objfiles in the progspace.
 271    Objfiles that are separate debug objfiles are *not* included in the result,
 272    only the "original/real" one appears in the result.
 273    The order of appearance of objfiles in the result is arbitrary.
 274    Throw's an exception if the underlying pspace is invalid.
 275
 276    Some apps can have 1000s of shared libraries.  Seriously.
 277    A future extension here could be to provide, e.g., a regexp to select
 278    just the ones the caller is interested in (rather than building the list
 279    and then selecting the desired ones).  Another alternative is passing a
 280    predicate, then the filter criteria can be more general.  */
 281
 282 static SCM
 283 gdbscm_progspace_objfiles (SCM self)
 284 {
 285   pspace_smob *p_smob
 286     = psscm_get_valid_pspace_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 287   SCM result;
 288
 289   result = SCM_EOL;
 290
 291   for (objfile *objfile : p_smob->pspace->objfiles ())
 292     {
 293       if (objfile->separate_debug_objfile_backlink == NULL)
 294         {
 295           SCM item = ofscm_scm_from_objfile (objfile);
 296
 297           result = scm_cons (item, result);
 298         }
 299     }
 300
 301   /* We don't really have to return the list in the same order as recorded
 302      internally, but for consistency we do.  We still advertise that one
 303      cannot assume anything about the order.  */
 304   return scm_reverse_x (result, SCM_EOL);
 305 }
 306
 307 /* (progspace-pretty-printers <gdb:progspace>) -> list
 308    Returns the list of pretty-printers for this program space.  */
 309
 310 static SCM
 311 gdbscm_progspace_pretty_printers (SCM self)
 312 {
 313   pspace_smob *p_smob
 314     = psscm_get_pspace_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 315
 316   return p_smob->pretty_printers;
 317 }
 318
 319 /* (set-progspace-pretty-printers! <gdb:progspace> list) -> unspecified
 320    Set the pretty-printers for this program space.  */
 321
 322 static SCM
 323 gdbscm_set_progspace_pretty_printers_x (SCM self, SCM printers)
 324 {
 325   pspace_smob *p_smob
 326     = psscm_get_pspace_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 327
 328   SCM_ASSERT_TYPE (gdbscm_is_true (scm_list_p (printers)), printers,
 329                    SCM_ARG2, FUNC_NAME, _("list"));
 330
 331   p_smob->pretty_printers = printers;
 332
 333   return SCM_UNSPECIFIED;
 334 }
 335
 336 /* (current-progspace) -> <gdb:progspace>
 337    Return the current program space.  There always is one.  */
 338
 339 static SCM
 340 gdbscm_current_progspace (void)
 341 {
 342   SCM result;
 343
 344   result = psscm_scm_from_pspace (current_program_space);
 345
 346   return result;
 347 }
 348
 349 /* (progspaces) -> list
 350    Return a list of all progspaces.  */
 351
 352 static SCM
 353 gdbscm_progspaces (void)
 354 {
 355   SCM result;
 356
 357   result = SCM_EOL;
 358
 359   for (struct program_space *ps : program_spaces)
 360     {
 361       SCM item = psscm_scm_from_pspace (ps);
 362
 363       result = scm_cons (item, result);
 364     }
 365
 366   return scm_reverse_x (result, SCM_EOL);
 367 }
 368 \f
 369 /* Initialize the Scheme program space support.  */
 370
 371 static const scheme_function pspace_functions[] =
 372 {
 373   { "progspace?", 1, 0, 0, as_a_scm_t_subr (gdbscm_progspace_p),
 374     "\
 375 Return #t if the object is a <gdb:objfile> object." },
 376
 377   { "progspace-valid?", 1, 0, 0, as_a_scm_t_subr (gdbscm_progspace_valid_p),
 378     "\
 379 Return #t if the progspace is valid (hasn't been deleted from gdb)." },
 380
 381   { "progspace-filename", 1, 0, 0, as_a_scm_t_subr (gdbscm_progspace_filename),
 382     "\
 383 Return the name of the main symbol file of the progspace." },
 384
 385   { "progspace-objfiles", 1, 0, 0, as_a_scm_t_subr (gdbscm_progspace_objfiles),
 386     "\
 387 Return the list of objfiles associated with the progspace.\n\
 388 Objfiles that are separate debug objfiles are not included in the result.\n\
 389 The order of appearance of objfiles in the result is arbitrary." },
 390
 391   { "progspace-pretty-printers", 1, 0, 0,
 392     as_a_scm_t_subr (gdbscm_progspace_pretty_printers),
 393     "\
 394 Return a list of pretty-printers of the progspace." },
 395
 396   { "set-progspace-pretty-printers!", 2, 0, 0,
 397     as_a_scm_t_subr (gdbscm_set_progspace_pretty_printers_x),
 398     "\
 399 Set the list of pretty-printers of the progspace." },
 400
 401   { "current-progspace", 0, 0, 0, as_a_scm_t_subr (gdbscm_current_progspace),
 402     "\
 403 Return the current program space if there is one or #f if there isn't one." },
 404
 405   { "progspaces", 0, 0, 0, as_a_scm_t_subr (gdbscm_progspaces),
 406     "\
 407 Return a list of all program spaces." },
 408
 409   END_FUNCTIONS
 410 };
 411
 412 void
 413 gdbscm_initialize_pspaces (void)
 414 {
 415   pspace_smob_tag
 416     = gdbscm_make_smob_type (pspace_smob_name, sizeof (pspace_smob));
 417   scm_set_smob_print (pspace_smob_tag, psscm_print_pspace_smob);
 418
 419   gdbscm_define_functions (pspace_functions, 1);
 420 }
 421
 422 void _initialize_scm_progspace ();
 423 void
 424 _initialize_scm_progspace ()
 425 {
 426   psscm_pspace_data_key
 427     = register_program_space_data_with_cleanup (NULL,
 428                                                 psscm_handle_pspace_deleted);
 429 }