gdb/guile/scm-gsmob.c

   1 /* GDB/Scheme smobs (gsmob is pronounced "jee smob")
   2
   3    Copyright (C) 2014-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 /* 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 "hashtab.h"
  45 #include "objfiles.h"
  46 #include "guile-internal.h"
  47
  48 /* We need to call this.  Undo our hack to prevent others from calling it.  */
  49 #undef scm_make_smob_type
  50
  51 static htab_t registered_gsmobs;
  52
  53 /* Hash function for registered_gsmobs hash table.  */
  54
  55 static hashval_t
  56 hash_scm_t_bits (const void *item)
  57 {
  58   uintptr_t v = (uintptr_t) item;
  59
  60   return v;
  61 }
  62
  63 /* Equality function for registered_gsmobs hash table.  */
  64
  65 static int
  66 eq_scm_t_bits (const void *item_lhs, const void *item_rhs)
  67 {
  68   return item_lhs == item_rhs;
  69 }
  70
  71 /* Record GSMOB_CODE as being a gdb smob.
  72    GSMOB_CODE is the result of scm_make_smob_type.  */
  73
  74 static void
  75 register_gsmob (scm_t_bits gsmob_code)
  76 {
  77   void **slot;
  78
  79   slot = htab_find_slot (registered_gsmobs, (void *) gsmob_code, INSERT);
  80   gdb_assert (*slot == NULL);
  81   *slot = (void *) gsmob_code;
  82 }
  83
  84 /* Return non-zero if SCM is any registered gdb smob object.  */
  85
  86 static int
  87 gdbscm_is_gsmob (SCM scm)
  88 {
  89   void **slot;
  90
  91   if (SCM_IMP (scm))
  92     return 0;
  93   slot = htab_find_slot (registered_gsmobs, (void *) SCM_TYP16 (scm),
  94                          NO_INSERT);
  95   return slot != NULL;
  96 }
  97
  98 /* Call this to register a smob, instead of scm_make_smob_type.
  99    Exports the created smob type from the current module.  */
 100
 101 scm_t_bits
 102 gdbscm_make_smob_type (const char *name, size_t size)
 103 {
 104   scm_t_bits result = scm_make_smob_type (name, size);
 105
 106   register_gsmob (result);
 107
 108 #if SCM_MAJOR_VERSION == 2 && SCM_MINOR_VERSION == 0
 109   /* Prior to Guile 2.1.0, smob classes were only exposed via exports
 110      from the (oop goops) module.  */
 111   SCM bound_name = scm_string_append (scm_list_3 (scm_from_latin1_string ("<"),
 112                                                   scm_from_latin1_string (name),
 113                                                   scm_from_latin1_string (">")));
 114   bound_name = scm_string_to_symbol (bound_name);
 115   SCM smob_type = scm_public_ref (scm_list_2 (scm_from_latin1_symbol ("oop"),
 116                                               scm_from_latin1_symbol ("goops")),
 117                                   bound_name);
 118 #elif SCM_MAJOR_VERSION == 2 && SCM_MINOR_VERSION == 1 && SCM_MICRO_VERSION == 0
 119   /* Guile 2.1.0 doesn't provide any API for looking up smob classes.
 120      We could try allocating a fake instance and using scm_class_of,
 121      but it's probably not worth the trouble for the sake of a single
 122      development release.  */
 123 #  error "Unsupported Guile version"
 124 #else
 125   /* Guile 2.1.1 and above provides scm_smob_type_class.  */
 126   SCM smob_type = scm_smob_type_class (result);
 127 #endif
 128
 129   SCM smob_type_name = scm_class_name (smob_type);
 130   scm_define (smob_type_name, smob_type);
 131   scm_module_export (scm_current_module (), scm_list_1 (smob_type_name));
 132
 133   return result;
 134 }
 135
 136 /* Initialize a gsmob.  */
 137
 138 void
 139 gdbscm_init_gsmob (gdb_smob *base)
 140 {
 141   base->empty_base_class = 0;
 142 }
 143
 144 /* Initialize a chained_gdb_smob.
 145    This is the same as gdbscm_init_gsmob except that it also sets prev,next
 146    to NULL.  */
 147
 148 void
 149 gdbscm_init_chained_gsmob (chained_gdb_smob *base)
 150 {
 151   gdbscm_init_gsmob ((gdb_smob *) base);
 152   base->prev = NULL;
 153   base->next = NULL;
 154 }
 155
 156 /* Initialize an eqable_gdb_smob.
 157    This is the same as gdbscm_init_gsmob except that it also sets
 158    BASE->containing_scm to CONTAINING_SCM.  */
 159
 160 void
 161 gdbscm_init_eqable_gsmob (eqable_gdb_smob *base, SCM containing_scm)
 162 {
 163   gdbscm_init_gsmob ((gdb_smob *) base);
 164   base->containing_scm = containing_scm;
 165 }
 166
 167 \f
 168 /* gsmob accessors */
 169
 170 /* Return the gsmob in SELF.
 171    Throws an exception if SELF is not a gsmob.  */
 172
 173 static SCM
 174 gsscm_get_gsmob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
 175 {
 176   SCM_ASSERT_TYPE (gdbscm_is_gsmob (self), self, arg_pos, func_name,
 177                    _("any gdb smob"));
 178
 179   return self;
 180 }
 181
 182 /* (gdb-object-kind gsmob) -> symbol
 183
 184    Note: While one might want to name this gdb-object-class-name, it is named
 185    "-kind" because smobs aren't real GOOPS classes.  */
 186
 187 static SCM
 188 gdbscm_gsmob_kind (SCM self)
 189 {
 190   SCM smob, result;
 191   scm_t_bits smobnum;
 192   const char *name;
 193
 194   smob = gsscm_get_gsmob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 195
 196   smobnum = SCM_SMOBNUM (smob);
 197   name = SCM_SMOBNAME (smobnum);
 198   gdb::unique_xmalloc_ptr<char> kind = xstrprintf ("<%s>", name);
 199   result = scm_from_latin1_symbol (kind.get ());
 200   return result;
 201 }
 202
 203 \f
 204 /* When underlying gdb data structures are deleted, we need to update any
 205    smobs with references to them.  There are several smobs that reference
 206    objfile-based data, so we provide helpers to manage this.  */
 207
 208 /* Create a hash table for mapping a pointer to a gdb data structure to the
 209    gsmob that wraps it.  */
 210
 211 htab_t
 212 gdbscm_create_eqable_gsmob_ptr_map (htab_hash hash_fn, htab_eq eq_fn)
 213 {
 214   htab_t htab = htab_create_alloc (7, hash_fn, eq_fn,
 215                                    NULL, xcalloc, xfree);
 216
 217   return htab;
 218 }
 219
 220 /* Return a pointer to the htab entry for the eq?-able gsmob BASE.
 221    If the entry is found, *SLOT is non-NULL.
 222    Otherwise *slot is NULL.  */
 223
 224 eqable_gdb_smob **
 225 gdbscm_find_eqable_gsmob_ptr_slot (htab_t htab, eqable_gdb_smob *base)
 226 {
 227   void **slot = htab_find_slot (htab, base, INSERT);
 228
 229   return (eqable_gdb_smob **) slot;
 230 }
 231
 232 /* Record BASE in SLOT.  SLOT must be the result of calling
 233    gdbscm_find_eqable_gsmob_ptr_slot on BASE (or equivalent for lookup).  */
 234
 235 void
 236 gdbscm_fill_eqable_gsmob_ptr_slot (eqable_gdb_smob **slot,
 237                                    eqable_gdb_smob *base)
 238 {
 239   *slot = base;
 240 }
 241
 242 /* Remove BASE from HTAB.
 243    BASE is a pointer to a gsmob that wraps a pointer to a GDB datum.
 244    This is used, for example, when an object is freed.
 245
 246    It is an error to call this if PTR is not in HTAB (only because it allows
 247    for some consistency checking).  */
 248
 249 void
 250 gdbscm_clear_eqable_gsmob_ptr_slot (htab_t htab, eqable_gdb_smob *base)
 251 {
 252   void **slot = htab_find_slot (htab, base, NO_INSERT);
 253
 254   gdb_assert (slot != NULL);
 255   htab_clear_slot (htab, slot);
 256 }
 257 \f
 258 /* Initialize the Scheme gsmobs code.  */
 259
 260 static const scheme_function gsmob_functions[] =
 261 {
 262   /* N.B. There is a general rule of not naming symbols in gdb-guile with a
 263      "gdb" prefix.  This symbol does not violate this rule because it is to
 264      be read as "gdb-object-foo", not "gdb-foo".  */
 265   { "gdb-object-kind", 1, 0, 0, as_a_scm_t_subr (gdbscm_gsmob_kind),
 266     "\
 267 Return the kind of the GDB object, e.g., <gdb:breakpoint>, as a symbol." },
 268
 269   END_FUNCTIONS
 270 };
 271
 272 void
 273 gdbscm_initialize_smobs (void)
 274 {
 275   registered_gsmobs = htab_create_alloc (10,
 276                                          hash_scm_t_bits, eq_scm_t_bits,
 277                                          NULL, xcalloc, xfree);
 278
 279   gdbscm_define_functions (gsmob_functions, 1);
 280 }