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    We want the objects we export to Scheme to be extensible by the user.
  34    A gsmob (gdb smob) adds a simple API on top of smobs to support this.
  35    This allows GDB objects to be easily extendable in a useful manner.
  36    To that end, all smobs in gdb have gdb_smob as the first member.
  37
  38    On top of gsmobs there are "chained gsmobs".  They are used to assist with
  39    life-time tracking of GDB objects vs Scheme objects.  Gsmobs can "subclass"
  40    chained_gdb_smob, which contains a doubly-linked list to assist with
  41    life-time tracking.
  42
  43    On top of gsmobs there are also "eqable gsmobs".  Gsmobs can "subclass"
  44    eqable_gdb_smob instead of gdb_smob, and is used to make gsmobs eq?-able.
  45    This is done by recording all gsmobs in a hash table and before creating a
  46    gsmob first seeing if it's already in the table.  Eqable gsmobs can also be
  47    used where lifetime-tracking is required.
  48
  49    Gsmobs (and chained/eqable gsmobs) add an extra field that is used to
  50    record extra data: "properties".  It is a table of key/value pairs
  51    that can be set with set-gsmob-property!, gsmob-property.  */
  52
  53 #include "defs.h"
  54 #include "hashtab.h"
  55 #include "gdb_assert.h"
  56 #include "objfiles.h"
  57 #include "guile-internal.h"
  58
  59 /* We need to call this.  Undo our hack to prevent others from calling it.  */
  60 #undef scm_make_smob_type
  61
  62 static htab_t registered_gsmobs;
  63
  64 /* Gsmob properties are initialize stored as an alist to minimize space
  65    usage: GDB can be used to debug some really big programs, and property
  66    lists generally have very few elements.  Once the list grows to this
  67    many elements then we switch to a hash table.
  68    The smallest Guile hashtable in 2.0 uses a vector of 31 elements.
  69    The value we use here is large enough to hold several expected uses,
  70    without being so large that we might as well just use a hashtable.  */
  71 #define SMOB_PROP_HTAB_THRESHOLD 7
  72
  73 /* Hash function for registered_gsmobs hash table.  */
  74
  75 static hashval_t
  76 hash_scm_t_bits (const void *item)
  77 {
  78   uintptr_t v = (uintptr_t) item;
  79
  80   return v;
  81 }
  82
  83 /* Equality function for registered_gsmobs hash table.  */
  84
  85 static int
  86 eq_scm_t_bits (const void *item_lhs, const void *item_rhs)
  87 {
  88   return item_lhs == item_rhs;
  89 }
  90
  91 /* Record GSMOB_CODE as being a gdb smob.
  92    GSMOB_CODE is the result of scm_make_smob_type.  */
  93
  94 static void
  95 register_gsmob (scm_t_bits gsmob_code)
  96 {
  97   void **slot;
  98
  99   slot = htab_find_slot (registered_gsmobs, (void *) gsmob_code, INSERT);
 100   gdb_assert (*slot == NULL);
 101   *slot = (void *) gsmob_code;
 102 }
 103
 104 /* Return non-zero if SCM is any registered gdb smob object.  */
 105
 106 static int
 107 gdbscm_is_gsmob (SCM scm)
 108 {
 109   void **slot;
 110
 111   if (SCM_IMP (scm))
 112     return 0;
 113   slot = htab_find_slot (registered_gsmobs, (void *) SCM_TYP16 (scm),
 114                          NO_INSERT);
 115   return slot != NULL;
 116 }
 117
 118 /* Call this to register a smob, instead of scm_make_smob_type.  */
 119
 120 scm_t_bits
 121 gdbscm_make_smob_type (const char *name, size_t size)
 122 {
 123   scm_t_bits result = scm_make_smob_type (name, size);
 124
 125   register_gsmob (result);
 126   return result;
 127 }
 128
 129 /* Initialize a gsmob.  */
 130
 131 void
 132 gdbscm_init_gsmob (gdb_smob *base)
 133 {
 134   base->properties = SCM_EOL;
 135 }
 136
 137 /* Initialize a chained_gdb_smob.
 138    This is the same as gdbscm_init_gsmob except that it also sets prev,next
 139    to NULL.  */
 140
 141 void
 142 gdbscm_init_chained_gsmob (chained_gdb_smob *base)
 143 {
 144   gdbscm_init_gsmob ((gdb_smob *) base);
 145   base->prev = NULL;
 146   base->next = NULL;
 147 }
 148
 149 /* Initialize an eqable_gdb_smob.
 150    This is the same as gdbscm_init_gsmob except that it also sets
 151    BASE->containing_scm to CONTAINING_SCM.  */
 152
 153 void
 154 gdbscm_init_eqable_gsmob (eqable_gdb_smob *base, SCM containing_scm)
 155 {
 156   gdbscm_init_gsmob ((gdb_smob *) base);
 157   base->containing_scm = containing_scm;
 158 }
 159
 160 /* Call this from each smob's "mark" routine.
 161    In general, this should be called as:
 162    return gdbscm_mark_gsmob (base);  */
 163
 164 SCM
 165 gdbscm_mark_gsmob (gdb_smob *base)
 166 {
 167   /* Return the last one to mark as an optimization.
 168      The marking infrastructure will mark it for us.  */
 169   return base->properties;
 170 }
 171
 172 /* Call this from each smob's "mark" routine.
 173    In general, this should be called as:
 174    return gdbscm_mark_chained_gsmob (base);  */
 175
 176 SCM
 177 gdbscm_mark_chained_gsmob (chained_gdb_smob *base)
 178 {
 179   /* Return the last one to mark as an optimization.
 180      The marking infrastructure will mark it for us.  */
 181   return base->properties;
 182 }
 183
 184 /* Call this from each smob's "mark" routine.
 185    In general, this should be called as:
 186    return gdbscm_mark_eqable_gsmob (base);  */
 187
 188 SCM
 189 gdbscm_mark_eqable_gsmob (eqable_gdb_smob *base)
 190 {
 191   /* There's no need to mark containing_scm.
 192      Any references to it either come from Scheme in which case it will be
 193      marked through them, or there's a reference to the smob from gdb in
 194      which case the smob is GC-protected.  */
 195
 196   /* Return the last one to mark as an optimization.
 197      The marking infrastructure will mark it for us.  */
 198   return base->properties;
 199 }
 200 \f
 201 /* gsmob accessors */
 202
 203 /* Return the gsmob in SELF.
 204    Throws an exception if SELF is not a gsmob.  */
 205
 206 static SCM
 207 gsscm_get_gsmob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
 208 {
 209   SCM_ASSERT_TYPE (gdbscm_is_gsmob (self), self, arg_pos, func_name,
 210                    _("any gdb smob"));
 211
 212   return self;
 213 }
 214
 215 /* (gsmob-kind gsmob) -> symbol
 216
 217    Note: While one might want to name this gsmob-class-name, it is named
 218    "-kind" because smobs aren't real GOOPS classes.  */
 219
 220 static SCM
 221 gdbscm_gsmob_kind (SCM self)
 222 {
 223   SCM smob, result;
 224   scm_t_bits smobnum;
 225   const char *name;
 226   char *kind;
 227
 228   smob = gsscm_get_gsmob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 229
 230   smobnum = SCM_SMOBNUM (smob);
 231   name = SCM_SMOBNAME (smobnum);
 232   kind = xstrprintf ("<%s>", name);
 233   result = scm_from_latin1_symbol (kind);
 234   xfree (kind);
 235
 236   return result;
 237 }
 238
 239 /* (gsmob-property gsmob property) -> object
 240    If property isn't present then #f is returned.  */
 241
 242 static SCM
 243 gdbscm_gsmob_property (SCM self, SCM property)
 244 {
 245   SCM smob;
 246   gdb_smob *base;
 247
 248   smob = gsscm_get_gsmob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 249   base = (gdb_smob *) SCM_SMOB_DATA (self);
 250
 251   /* Have we switched to a hash table?  */
 252   if (gdbscm_is_true (scm_hash_table_p (base->properties)))
 253     return scm_hashq_ref (base->properties, property, SCM_BOOL_F);
 254
 255   return scm_assq_ref (base->properties, property);
 256 }
 257
 258 /* (set-gsmob-property! gsmob property new-value) -> unspecified */
 259
 260 static SCM
 261 gdbscm_set_gsmob_property_x (SCM self, SCM property, SCM new_value)
 262 {
 263   SCM smob, alist;
 264   gdb_smob *base;
 265
 266   smob = gsscm_get_gsmob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 267   base = (gdb_smob *) SCM_SMOB_DATA (self);
 268
 269   /* Have we switched to a hash table?  */
 270   if (gdbscm_is_true (scm_hash_table_p (base->properties)))
 271     {
 272       scm_hashq_set_x (base->properties, property, new_value);
 273       return SCM_UNSPECIFIED;
 274     }
 275
 276   alist = scm_assq_set_x (base->properties, property, new_value);
 277
 278   /* Did we grow the list?  */
 279   if (!scm_is_eq (alist, base->properties))
 280     {
 281       /* If we grew the list beyond a threshold in size,
 282          switch to a hash table.  */
 283       if (scm_ilength (alist) >= SMOB_PROP_HTAB_THRESHOLD)
 284         {
 285           SCM elm, htab;
 286
 287           htab = scm_c_make_hash_table (SMOB_PROP_HTAB_THRESHOLD);
 288           for (elm = alist; elm != SCM_EOL; elm = scm_cdr (elm))
 289             scm_hashq_set_x (htab, scm_caar (elm), scm_cdar (elm));
 290           base->properties = htab;
 291           return SCM_UNSPECIFIED;
 292         }
 293     }
 294
 295   base->properties = alist;
 296   return SCM_UNSPECIFIED;
 297 }
 298
 299 /* (gsmob-has-property? gsmob property) -> boolean */
 300
 301 static SCM
 302 gdbscm_gsmob_has_property_p (SCM self, SCM property)
 303 {
 304   SCM smob, handle;
 305   gdb_smob *base;
 306
 307   smob = gsscm_get_gsmob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 308   base = (gdb_smob *) SCM_SMOB_DATA (self);
 309
 310   if (gdbscm_is_true (scm_hash_table_p (base->properties)))
 311     handle = scm_hashq_get_handle (base->properties, property);
 312   else
 313     handle = scm_assq (property, base->properties);
 314
 315   return scm_from_bool (gdbscm_is_true (handle));
 316 }
 317
 318 /* Helper function for gdbscm_gsmob_properties.  */
 319
 320 static SCM
 321 add_property_name (void *closure, SCM handle)
 322 {
 323   SCM *resultp = closure;
 324
 325   *resultp = scm_cons (scm_car (handle), *resultp);
 326   return SCM_UNSPECIFIED;
 327 }
 328
 329 /* (gsmob-properties gsmob) -> list
 330    The list is unsorted.  */
 331
 332 static SCM
 333 gdbscm_gsmob_properties (SCM self)
 334 {
 335   SCM smob, handle, result;
 336   gdb_smob *base;
 337
 338   smob = gsscm_get_gsmob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 339   base = (gdb_smob *) SCM_SMOB_DATA (self);
 340
 341   result = SCM_EOL;
 342   if (gdbscm_is_true (scm_hash_table_p (base->properties)))
 343     {
 344       scm_internal_hash_for_each_handle (add_property_name, &result,
 345                                          base->properties);
 346     }
 347   else
 348     {
 349       SCM elm;
 350
 351       for (elm = base->properties; elm != SCM_EOL; elm = scm_cdr (elm))
 352         result = scm_cons (scm_caar (elm), result);
 353     }
 354
 355   return result;
 356 }
 357 \f
 358 /* When underlying gdb data structures are deleted, we need to update any
 359    smobs with references to them.  There are several smobs that reference
 360    objfile-based data, so we provide helpers to manage this.  */
 361
 362 /* Add G_SMOB to the reference chain for OBJFILE specified by DATA_KEY.
 363    OBJFILE may be NULL, in which case just set prev,next to NULL.  */
 364
 365 void
 366 gdbscm_add_objfile_ref (struct objfile *objfile,
 367                         const struct objfile_data *data_key,
 368                         chained_gdb_smob *g_smob)
 369 {
 370   g_smob->prev = NULL;
 371   if (objfile != NULL)
 372     {
 373       g_smob->next = objfile_data (objfile, data_key);
 374       if (g_smob->next)
 375         g_smob->next->prev = g_smob;
 376       set_objfile_data (objfile, data_key, g_smob);
 377     }
 378   else
 379     g_smob->next = NULL;
 380 }
 381
 382 /* Remove G_SMOB from the reference chain for OBJFILE specified
 383    by DATA_KEY.  OBJFILE may be NULL.  */
 384
 385 void
 386 gdbscm_remove_objfile_ref (struct objfile *objfile,
 387                            const struct objfile_data *data_key,
 388                            chained_gdb_smob *g_smob)
 389 {
 390   if (g_smob->prev)
 391     g_smob->prev->next = g_smob->next;
 392   else if (objfile != NULL)
 393     set_objfile_data (objfile, data_key, g_smob->next);
 394   if (g_smob->next)
 395     g_smob->next->prev = g_smob->prev;
 396 }
 397
 398 /* Create a hash table for mapping a pointer to a gdb data structure to the
 399    gsmob that wraps it.  */
 400
 401 htab_t
 402 gdbscm_create_eqable_gsmob_ptr_map (htab_hash hash_fn, htab_eq eq_fn)
 403 {
 404   htab_t htab = htab_create_alloc (7, hash_fn, eq_fn,
 405                                    NULL, xcalloc, xfree);
 406
 407   return htab;
 408 }
 409
 410 /* Return a pointer to the htab entry for the eq?-able gsmob BASE.
 411    If the entry is found, *SLOT is non-NULL.
 412    Otherwise *slot is NULL.  */
 413
 414 eqable_gdb_smob **
 415 gdbscm_find_eqable_gsmob_ptr_slot (htab_t htab, eqable_gdb_smob *base)
 416 {
 417   void **slot = htab_find_slot (htab, base, INSERT);
 418
 419   return (eqable_gdb_smob **) slot;
 420 }
 421
 422 /* Record BASE in SLOT.  SLOT must be the result of calling
 423    gdbscm_find_eqable_gsmob_ptr_slot on BASE (or equivalent for lookup).  */
 424
 425 void
 426 gdbscm_fill_eqable_gsmob_ptr_slot (eqable_gdb_smob **slot,
 427                                    eqable_gdb_smob *base)
 428 {
 429   *slot = base;
 430 }
 431
 432 /* Remove BASE from HTAB.
 433    BASE is a pointer to a gsmob that wraps a pointer to a GDB datum.
 434    This is used, for example, when an object is freed.
 435
 436    It is an error to call this if PTR is not in HTAB (only because it allows
 437    for some consistency checking).  */
 438
 439 void
 440 gdbscm_clear_eqable_gsmob_ptr_slot (htab_t htab, eqable_gdb_smob *base)
 441 {
 442   void **slot = htab_find_slot (htab, base, NO_INSERT);
 443
 444   gdb_assert (slot != NULL);
 445   htab_clear_slot (htab, slot);
 446 }
 447 \f
 448 /* Initialize the Scheme gsmobs code.  */
 449
 450 static const scheme_function gsmob_functions[] =
 451 {
 452   { "gsmob-kind", 1, 0, 0, gdbscm_gsmob_kind,
 453     "\
 454 Return the kind of the smob, e.g., <gdb:breakpoint>, as a symbol." },
 455
 456   { "gsmob-property", 2, 0, 0, gdbscm_gsmob_property,
 457     "\
 458 Return the specified property of the gsmob." },
 459
 460   { "set-gsmob-property!", 3, 0, 0, gdbscm_set_gsmob_property_x,
 461     "\
 462 Set the specified property of the gsmob." },
 463
 464   { "gsmob-has-property?", 2, 0, 0, gdbscm_gsmob_has_property_p,
 465     "\
 466 Return #t if the specified property is present." },
 467
 468   { "gsmob-properties", 1, 0, 0, gdbscm_gsmob_properties,
 469     "\
 470 Return an unsorted list of names of properties." },
 471
 472   END_FUNCTIONS
 473 };
 474
 475 void
 476 gdbscm_initialize_smobs (void)
 477 {
 478   registered_gsmobs = htab_create_alloc (10,
 479                                          hash_scm_t_bits, eq_scm_t_bits,
 480                                          NULL, xcalloc, xfree);
 481
 482   gdbscm_define_functions (gsmob_functions, 1);
 483 }