gdb/guile/scm-progspace.c

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