Commit | Line | Data |
---|---|---|
ed3ef339 DE |
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 | containing_scm to #f. */ | |
152 | ||
153 | void | |
154 | gdbscm_init_eqable_gsmob (eqable_gdb_smob *base) | |
155 | { | |
156 | gdbscm_init_gsmob ((gdb_smob *) base); | |
157 | base->containing_scm = SCM_BOOL_F; | |
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 CONTAINING_SCM as the object containing BASE, and record it in | |
423 | SLOT. SLOT must be the result of calling gdbscm_find_eqable_gsmob_ptr_slot | |
424 | on BASE (or equivalent for lookup). */ | |
425 | ||
426 | void | |
427 | gdbscm_fill_eqable_gsmob_ptr_slot (eqable_gdb_smob **slot, | |
428 | eqable_gdb_smob *base, | |
429 | SCM containing_scm) | |
430 | { | |
431 | base->containing_scm = containing_scm; | |
432 | *slot = base; | |
433 | } | |
434 | ||
435 | /* Remove BASE from HTAB. | |
436 | BASE is a pointer to a gsmob that wraps a pointer to a GDB datum. | |
437 | This is used, for example, when an object is freed. | |
438 | ||
439 | It is an error to call this if PTR is not in HTAB (only because it allows | |
440 | for some consistency checking). */ | |
441 | ||
442 | void | |
443 | gdbscm_clear_eqable_gsmob_ptr_slot (htab_t htab, eqable_gdb_smob *base) | |
444 | { | |
445 | void **slot = htab_find_slot (htab, base, NO_INSERT); | |
446 | ||
447 | gdb_assert (slot != NULL); | |
448 | htab_clear_slot (htab, slot); | |
449 | } | |
450 | \f | |
451 | /* Initialize the Scheme gsmobs code. */ | |
452 | ||
453 | static const scheme_function gsmob_functions[] = | |
454 | { | |
455 | { "gsmob-kind", 1, 0, 0, gdbscm_gsmob_kind, | |
456 | "\ | |
457 | Return the kind of the smob, e.g., <gdb:breakpoint>, as a symbol." }, | |
458 | ||
459 | { "gsmob-property", 2, 0, 0, gdbscm_gsmob_property, | |
460 | "\ | |
461 | Return the specified property of the gsmob." }, | |
462 | ||
463 | { "set-gsmob-property!", 3, 0, 0, gdbscm_set_gsmob_property_x, | |
464 | "\ | |
465 | Set the specified property of the gsmob." }, | |
466 | ||
467 | { "gsmob-has-property?", 2, 0, 0, gdbscm_gsmob_has_property_p, | |
468 | "\ | |
469 | Return #t if the specified property is present." }, | |
470 | ||
471 | { "gsmob-properties", 1, 0, 0, gdbscm_gsmob_properties, | |
472 | "\ | |
473 | Return an unsorted list of names of properties." }, | |
474 | ||
475 | END_FUNCTIONS | |
476 | }; | |
477 | ||
478 | void | |
479 | gdbscm_initialize_smobs (void) | |
480 | { | |
481 | registered_gsmobs = htab_create_alloc (10, | |
482 | hash_scm_t_bits, eq_scm_t_bits, | |
483 | NULL, xcalloc, xfree); | |
484 | ||
485 | gdbscm_define_functions (gsmob_functions, 1); | |
486 | } |