gdb/guile/scm-gsmob.c

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