gdb/guile/scm-progspace.c

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