gdb/guile/scm-gsmob.c

   1 /* GDB/Scheme smobs (gsmob is pronounced "jee smob")
   2
   3    Copyright (C) 2014-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 /* See README file in this directory for implementation notes, coding
  21    conventions, et.al.  */
  22
  23 /* Smobs are Guile's "small object".
  24    They are used to export C structs to Scheme.
  25
  26    Note: There's only room in the encoding space for 256, and while we won't
  27    come close to that, mixed with other libraries maybe someday we could.
  28    We don't worry about it now, except to be aware of the issue.
  29    We could allocate just a few smobs and use the unused smob flags field to
  30    specify the gdb smob kind, that is left for another day if it ever is
  31    needed.
  32
  33    Some GDB smobs are "chained gsmobs".  They are used to assist with life-time
  34    tracking of GDB objects vs Scheme objects.  Gsmobs can "subclass"
  35    chained_gdb_smob, which contains a doubly-linked list to assist with
  36    life-time tracking.
  37
  38    Some other GDB smobs are "eqable gsmobs".  Gsmob implementations can
  39    "subclass" eqable_gdb_smob to make gsmobs eq?-able.  This is done by
  40    recording all gsmobs in a hash table and before creating a gsmob first
  41    seeing if it's already in the table.  Eqable gsmobs can also be used where
  42    lifetime-tracking is required.  */
  43
  44 #include "defs.h"
  45 #include "hashtab.h"
  46 #include "objfiles.h"
  47 #include "guile-internal.h"
  48
  49 /* We need to call this.  Undo our hack to prevent others from calling it.  */
  50 #undef scm_make_smob_type
  51
  52 static htab_t registered_gsmobs;
  53
  54 /* Hash function for registered_gsmobs hash table.  */
  55
  56 static hashval_t
  57 hash_scm_t_bits (const void *item)
  58 {
  59   uintptr_t v = (uintptr_t) item;
  60
  61   return v;
  62 }
  63
  64 /* Equality function for registered_gsmobs hash table.  */
  65
  66 static int
  67 eq_scm_t_bits (const void *item_lhs, const void *item_rhs)
  68 {
  69   return item_lhs == item_rhs;
  70 }
  71
  72 /* Record GSMOB_CODE as being a gdb smob.
  73    GSMOB_CODE is the result of scm_make_smob_type.  */
  74
  75 static void
  76 register_gsmob (scm_t_bits gsmob_code)
  77 {
  78   void **slot;
  79
  80   slot = htab_find_slot (registered_gsmobs, (void *) gsmob_code, INSERT);
  81   gdb_assert (*slot == NULL);
  82   *slot = (void *) gsmob_code;
  83 }
  84
  85 /* Return non-zero if SCM is any registered gdb smob object.  */
  86
  87 static int
  88 gdbscm_is_gsmob (SCM scm)
  89 {
  90   void **slot;
  91
  92   if (SCM_IMP (scm))
  93     return 0;
  94   slot = htab_find_slot (registered_gsmobs, (void *) SCM_TYP16 (scm),
  95                          NO_INSERT);
  96   return slot != NULL;
  97 }
  98
  99 /* Call this to register a smob, instead of scm_make_smob_type.
 100    Exports the created smob type from the current module.  */
 101
 102 scm_t_bits
 103 gdbscm_make_smob_type (const char *name, size_t size)
 104 {
 105   scm_t_bits result = scm_make_smob_type (name, size);
 106
 107   register_gsmob (result);
 108
 109 #if SCM_MAJOR_VERSION == 2 && SCM_MINOR_VERSION == 0
 110   /* Prior to Guile 2.1.0, smob classes were only exposed via exports
 111      from the (oop goops) module.  */
 112   SCM bound_name = scm_string_append (scm_list_3 (scm_from_latin1_string ("<"),
 113                                                   scm_from_latin1_string (name),
 114                                                   scm_from_latin1_string (">")));
 115   bound_name = scm_string_to_symbol (bound_name);
 116   SCM smob_type = scm_public_ref (scm_list_2 (scm_from_latin1_symbol ("oop"),
 117                                               scm_from_latin1_symbol ("goops")),
 118                                   bound_name);
 119 #elif SCM_MAJOR_VERSION == 2 && SCM_MINOR_VERSION == 1 && SCM_MICRO_VERSION == 0
 120   /* Guile 2.1.0 doesn't provide any API for looking up smob classes.
 121      We could try allocating a fake instance and using scm_class_of,
 122      but it's probably not worth the trouble for the sake of a single
 123      development release.  */
 124 #  error "Unsupported Guile version"
 125 #else
 126   /* Guile 2.1.1 and above provides scm_smob_type_class.  */
 127   SCM smob_type = scm_smob_type_class (result);
 128 #endif
 129
 130   SCM smob_type_name = scm_class_name (smob_type);
 131   scm_define (smob_type_name, smob_type);
 132   scm_module_export (scm_current_module (), scm_list_1 (smob_type_name));
 133
 134   return result;
 135 }
 136
 137 /* Initialize a gsmob.  */
 138
 139 void
 140 gdbscm_init_gsmob (gdb_smob *base)
 141 {
 142   base->empty_base_class = 0;
 143 }
 144
 145 /* Initialize a chained_gdb_smob.
 146    This is the same as gdbscm_init_gsmob except that it also sets prev,next
 147    to NULL.  */
 148
 149 void
 150 gdbscm_init_chained_gsmob (chained_gdb_smob *base)
 151 {
 152   gdbscm_init_gsmob ((gdb_smob *) base);
 153   base->prev = NULL;
 154   base->next = NULL;
 155 }
 156
 157 /* Initialize an eqable_gdb_smob.
 158    This is the same as gdbscm_init_gsmob except that it also sets
 159    BASE->containing_scm to CONTAINING_SCM.  */
 160
 161 void
 162 gdbscm_init_eqable_gsmob (eqable_gdb_smob *base, SCM containing_scm)
 163 {
 164   gdbscm_init_gsmob ((gdb_smob *) base);
 165   base->containing_scm = containing_scm;
 166 }
 167
 168 \f
 169 /* gsmob accessors */
 170
 171 /* Return the gsmob in SELF.
 172    Throws an exception if SELF is not a gsmob.  */
 173
 174 static SCM
 175 gsscm_get_gsmob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
 176 {
 177   SCM_ASSERT_TYPE (gdbscm_is_gsmob (self), self, arg_pos, func_name,
 178                    _("any gdb smob"));
 179
 180   return self;
 181 }
 182
 183 /* (gdb-object-kind gsmob) -> symbol
 184
 185    Note: While one might want to name this gdb-object-class-name, it is named
 186    "-kind" because smobs aren't real GOOPS classes.  */
 187
 188 static SCM
 189 gdbscm_gsmob_kind (SCM self)
 190 {
 191   SCM smob, result;
 192   scm_t_bits smobnum;
 193   const char *name;
 194   char *kind;
 195
 196   smob = gsscm_get_gsmob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 197
 198   smobnum = SCM_SMOBNUM (smob);
 199   name = SCM_SMOBNAME (smobnum);
 200   kind = xstrprintf ("<%s>", name);
 201   result = scm_from_latin1_symbol (kind);
 202   xfree (kind);
 203
 204   return result;
 205 }
 206
 207 \f
 208 /* When underlying gdb data structures are deleted, we need to update any
 209    smobs with references to them.  There are several smobs that reference
 210    objfile-based data, so we provide helpers to manage this.  */
 211
 212 /* Add G_SMOB to the reference chain for OBJFILE specified by DATA_KEY.
 213    OBJFILE may be NULL, in which case just set prev,next to NULL.  */
 214
 215 void
 216 gdbscm_add_objfile_ref (struct objfile *objfile,
 217                         const struct objfile_data *data_key,
 218                         chained_gdb_smob *g_smob)
 219 {
 220   g_smob->prev = NULL;
 221   if (objfile != NULL)
 222     {
 223       g_smob->next = (chained_gdb_smob *) objfile_data (objfile, data_key);
 224       if (g_smob->next)
 225         g_smob->next->prev = g_smob;
 226       set_objfile_data (objfile, data_key, g_smob);
 227     }
 228   else
 229     g_smob->next = NULL;
 230 }
 231
 232 /* Remove G_SMOB from the reference chain for OBJFILE specified
 233    by DATA_KEY.  OBJFILE may be NULL.  */
 234
 235 void
 236 gdbscm_remove_objfile_ref (struct objfile *objfile,
 237                            const struct objfile_data *data_key,
 238                            chained_gdb_smob *g_smob)
 239 {
 240   if (g_smob->prev)
 241     g_smob->prev->next = g_smob->next;
 242   else if (objfile != NULL)
 243     set_objfile_data (objfile, data_key, g_smob->next);
 244   if (g_smob->next)
 245     g_smob->next->prev = g_smob->prev;
 246 }
 247
 248 /* Create a hash table for mapping a pointer to a gdb data structure to the
 249    gsmob that wraps it.  */
 250
 251 htab_t
 252 gdbscm_create_eqable_gsmob_ptr_map (htab_hash hash_fn, htab_eq eq_fn)
 253 {
 254   htab_t htab = htab_create_alloc (7, hash_fn, eq_fn,
 255                                    NULL, xcalloc, xfree);
 256
 257   return htab;
 258 }
 259
 260 /* Return a pointer to the htab entry for the eq?-able gsmob BASE.
 261    If the entry is found, *SLOT is non-NULL.
 262    Otherwise *slot is NULL.  */
 263
 264 eqable_gdb_smob **
 265 gdbscm_find_eqable_gsmob_ptr_slot (htab_t htab, eqable_gdb_smob *base)
 266 {
 267   void **slot = htab_find_slot (htab, base, INSERT);
 268
 269   return (eqable_gdb_smob **) slot;
 270 }
 271
 272 /* Record BASE in SLOT.  SLOT must be the result of calling
 273    gdbscm_find_eqable_gsmob_ptr_slot on BASE (or equivalent for lookup).  */
 274
 275 void
 276 gdbscm_fill_eqable_gsmob_ptr_slot (eqable_gdb_smob **slot,
 277                                    eqable_gdb_smob *base)
 278 {
 279   *slot = base;
 280 }
 281
 282 /* Remove BASE from HTAB.
 283    BASE is a pointer to a gsmob that wraps a pointer to a GDB datum.
 284    This is used, for example, when an object is freed.
 285
 286    It is an error to call this if PTR is not in HTAB (only because it allows
 287    for some consistency checking).  */
 288
 289 void
 290 gdbscm_clear_eqable_gsmob_ptr_slot (htab_t htab, eqable_gdb_smob *base)
 291 {
 292   void **slot = htab_find_slot (htab, base, NO_INSERT);
 293
 294   gdb_assert (slot != NULL);
 295   htab_clear_slot (htab, slot);
 296 }
 297 \f
 298 /* Initialize the Scheme gsmobs code.  */
 299
 300 static const scheme_function gsmob_functions[] =
 301 {
 302   /* N.B. There is a general rule of not naming symbols in gdb-guile with a
 303      "gdb" prefix.  This symbol does not violate this rule because it is to
 304      be read as "gdb-object-foo", not "gdb-foo".  */
 305   { "gdb-object-kind", 1, 0, 0, as_a_scm_t_subr (gdbscm_gsmob_kind),
 306     "\
 307 Return the kind of the GDB object, e.g., <gdb:breakpoint>, as a symbol." },
 308
 309   END_FUNCTIONS
 310 };
 311
 312 void
 313 gdbscm_initialize_smobs (void)
 314 {
 315   registered_gsmobs = htab_create_alloc (10,
 316                                          hash_scm_t_bits, eq_scm_t_bits,
 317                                          NULL, xcalloc, xfree);
 318
 319   gdbscm_define_functions (gsmob_functions, 1);
 320 }