gdb/guile/scm-gsmob.c

   1 /* GDB/Scheme smobs (gsmob is pronounced "jee smob")
   2
   3    Copyright (C) 2014-2015 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
 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   return result;
 108 }
 109
 110 /* Initialize a gsmob.  */
 111
 112 void
 113 gdbscm_init_gsmob (gdb_smob *base)
 114 {
 115   base->empty_base_class = 0;
 116 }
 117
 118 /* Initialize a chained_gdb_smob.
 119    This is the same as gdbscm_init_gsmob except that it also sets prev,next
 120    to NULL.  */
 121
 122 void
 123 gdbscm_init_chained_gsmob (chained_gdb_smob *base)
 124 {
 125   gdbscm_init_gsmob ((gdb_smob *) base);
 126   base->prev = NULL;
 127   base->next = NULL;
 128 }
 129
 130 /* Initialize an eqable_gdb_smob.
 131    This is the same as gdbscm_init_gsmob except that it also sets
 132    BASE->containing_scm to CONTAINING_SCM.  */
 133
 134 void
 135 gdbscm_init_eqable_gsmob (eqable_gdb_smob *base, SCM containing_scm)
 136 {
 137   gdbscm_init_gsmob ((gdb_smob *) base);
 138   base->containing_scm = containing_scm;
 139 }
 140
 141 \f
 142 /* gsmob accessors */
 143
 144 /* Return the gsmob in SELF.
 145    Throws an exception if SELF is not a gsmob.  */
 146
 147 static SCM
 148 gsscm_get_gsmob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
 149 {
 150   SCM_ASSERT_TYPE (gdbscm_is_gsmob (self), self, arg_pos, func_name,
 151                    _("any gdb smob"));
 152
 153   return self;
 154 }
 155
 156 /* (gdb-object-kind gsmob) -> symbol
 157
 158    Note: While one might want to name this gdb-object-class-name, it is named
 159    "-kind" because smobs aren't real GOOPS classes.  */
 160
 161 static SCM
 162 gdbscm_gsmob_kind (SCM self)
 163 {
 164   SCM smob, result;
 165   scm_t_bits smobnum;
 166   const char *name;
 167   char *kind;
 168
 169   smob = gsscm_get_gsmob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 170
 171   smobnum = SCM_SMOBNUM (smob);
 172   name = SCM_SMOBNAME (smobnum);
 173   kind = xstrprintf ("<%s>", name);
 174   result = scm_from_latin1_symbol (kind);
 175   xfree (kind);
 176
 177   return result;
 178 }
 179
 180 \f
 181 /* When underlying gdb data structures are deleted, we need to update any
 182    smobs with references to them.  There are several smobs that reference
 183    objfile-based data, so we provide helpers to manage this.  */
 184
 185 /* Add G_SMOB to the reference chain for OBJFILE specified by DATA_KEY.
 186    OBJFILE may be NULL, in which case just set prev,next to NULL.  */
 187
 188 void
 189 gdbscm_add_objfile_ref (struct objfile *objfile,
 190                         const struct objfile_data *data_key,
 191                         chained_gdb_smob *g_smob)
 192 {
 193   g_smob->prev = NULL;
 194   if (objfile != NULL)
 195     {
 196       g_smob->next = (chained_gdb_smob *) objfile_data (objfile, data_key);
 197       if (g_smob->next)
 198         g_smob->next->prev = g_smob;
 199       set_objfile_data (objfile, data_key, g_smob);
 200     }
 201   else
 202     g_smob->next = NULL;
 203 }
 204
 205 /* Remove G_SMOB from the reference chain for OBJFILE specified
 206    by DATA_KEY.  OBJFILE may be NULL.  */
 207
 208 void
 209 gdbscm_remove_objfile_ref (struct objfile *objfile,
 210                            const struct objfile_data *data_key,
 211                            chained_gdb_smob *g_smob)
 212 {
 213   if (g_smob->prev)
 214     g_smob->prev->next = g_smob->next;
 215   else if (objfile != NULL)
 216     set_objfile_data (objfile, data_key, g_smob->next);
 217   if (g_smob->next)
 218     g_smob->next->prev = g_smob->prev;
 219 }
 220
 221 /* Create a hash table for mapping a pointer to a gdb data structure to the
 222    gsmob that wraps it.  */
 223
 224 htab_t
 225 gdbscm_create_eqable_gsmob_ptr_map (htab_hash hash_fn, htab_eq eq_fn)
 226 {
 227   htab_t htab = htab_create_alloc (7, hash_fn, eq_fn,
 228                                    NULL, xcalloc, xfree);
 229
 230   return htab;
 231 }
 232
 233 /* Return a pointer to the htab entry for the eq?-able gsmob BASE.
 234    If the entry is found, *SLOT is non-NULL.
 235    Otherwise *slot is NULL.  */
 236
 237 eqable_gdb_smob **
 238 gdbscm_find_eqable_gsmob_ptr_slot (htab_t htab, eqable_gdb_smob *base)
 239 {
 240   void **slot = htab_find_slot (htab, base, INSERT);
 241
 242   return (eqable_gdb_smob **) slot;
 243 }
 244
 245 /* Record BASE in SLOT.  SLOT must be the result of calling
 246    gdbscm_find_eqable_gsmob_ptr_slot on BASE (or equivalent for lookup).  */
 247
 248 void
 249 gdbscm_fill_eqable_gsmob_ptr_slot (eqable_gdb_smob **slot,
 250                                    eqable_gdb_smob *base)
 251 {
 252   *slot = base;
 253 }
 254
 255 /* Remove BASE from HTAB.
 256    BASE is a pointer to a gsmob that wraps a pointer to a GDB datum.
 257    This is used, for example, when an object is freed.
 258
 259    It is an error to call this if PTR is not in HTAB (only because it allows
 260    for some consistency checking).  */
 261
 262 void
 263 gdbscm_clear_eqable_gsmob_ptr_slot (htab_t htab, eqable_gdb_smob *base)
 264 {
 265   void **slot = htab_find_slot (htab, base, NO_INSERT);
 266
 267   gdb_assert (slot != NULL);
 268   htab_clear_slot (htab, slot);
 269 }
 270 \f
 271 /* Initialize the Scheme gsmobs code.  */
 272
 273 static const scheme_function gsmob_functions[] =
 274 {
 275   /* N.B. There is a general rule of not naming symbols in gdb-guile with a
 276      "gdb" prefix.  This symbol does not violate this rule because it is to
 277      be read as "gdb-object-foo", not "gdb-foo".  */
 278   { "gdb-object-kind", 1, 0, 0, as_a_scm_t_subr (gdbscm_gsmob_kind),
 279     "\
 280 Return the kind of the GDB object, e.g., <gdb:breakpoint>, as a symbol." },
 281
 282   END_FUNCTIONS
 283 };
 284
 285 void
 286 gdbscm_initialize_smobs (void)
 287 {
 288   registered_gsmobs = htab_create_alloc (10,
 289                                          hash_scm_t_bits, eq_scm_t_bits,
 290                                          NULL, xcalloc, xfree);
 291
 292   gdbscm_define_functions (gsmob_functions, 1);
 293 }