1 /* Scheme interface to blocks.
3 Copyright (C) 2008-2019 Free Software Foundation, Inc.
5 This file is part of GDB.
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.
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.
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/>. */
20 /* See README file in this directory for implementation notes, coding
21 conventions, et.al. */
25 #include "dictionary.h"
29 #include "guile-internal.h"
31 /* A smob describing a gdb block. */
33 typedef struct _block_smob
35 /* This always appears first.
36 We want blocks to be eq?-able. And we need to be able to invalidate
37 blocks when the associated objfile is deleted. */
40 /* The GDB block structure that represents a frame's code block. */
41 const struct block *block;
43 /* The backing object file. There is no direct relationship in GDB
44 between a block and an object file. When a block is created also
45 store a pointer to the object file for later use. */
46 struct objfile *objfile;
49 /* To iterate over block symbols from Scheme we need to store
50 struct block_iterator somewhere. This is stored in the "progress" field
51 of <gdb:iterator>. We store the block object in iterator_smob.object,
52 so we don't store it here.
54 Remember: While iterating over block symbols, you must continually check
55 whether the block is still valid. */
59 /* This always appears first. */
62 /* The iterator for that block. */
63 struct block_iterator iter;
65 /* Has the iterator been initialized flag. */
67 } block_syms_progress_smob;
69 static const char block_smob_name[] = "gdb:block";
70 static const char block_syms_progress_smob_name[] = "gdb:block-symbols-iterator";
72 /* The tag Guile knows the block smobs by. */
73 static scm_t_bits block_smob_tag;
74 static scm_t_bits block_syms_progress_smob_tag;
76 /* The "next!" block syms iterator method. */
77 static SCM bkscm_next_symbol_x_proc;
79 static const struct objfile_data *bkscm_objfile_data_key;
81 /* Administrivia for block smobs. */
83 /* Helper function to hash a block_smob. */
86 bkscm_hash_block_smob (const void *p)
88 const block_smob *b_smob = (const block_smob *) p;
90 return htab_hash_pointer (b_smob->block);
93 /* Helper function to compute equality of block_smobs. */
96 bkscm_eq_block_smob (const void *ap, const void *bp)
98 const block_smob *a = (const block_smob *) ap;
99 const block_smob *b = (const block_smob *) bp;
101 return (a->block == b->block
102 && a->block != NULL);
105 /* Return the struct block pointer -> SCM mapping table.
106 It is created if necessary. */
109 bkscm_objfile_block_map (struct objfile *objfile)
111 htab_t htab = (htab_t) objfile_data (objfile, bkscm_objfile_data_key);
115 htab = gdbscm_create_eqable_gsmob_ptr_map (bkscm_hash_block_smob,
116 bkscm_eq_block_smob);
117 set_objfile_data (objfile, bkscm_objfile_data_key, htab);
123 /* The smob "free" function for <gdb:block>. */
126 bkscm_free_block_smob (SCM self)
128 block_smob *b_smob = (block_smob *) SCM_SMOB_DATA (self);
130 if (b_smob->block != NULL)
132 htab_t htab = bkscm_objfile_block_map (b_smob->objfile);
134 gdbscm_clear_eqable_gsmob_ptr_slot (htab, &b_smob->base);
137 /* Not necessary, done to catch bugs. */
138 b_smob->block = NULL;
139 b_smob->objfile = NULL;
144 /* The smob "print" function for <gdb:block>. */
147 bkscm_print_block_smob (SCM self, SCM port, scm_print_state *pstate)
149 block_smob *b_smob = (block_smob *) SCM_SMOB_DATA (self);
150 const struct block *b = b_smob->block;
152 gdbscm_printf (port, "#<%s", block_smob_name);
154 if (BLOCK_SUPERBLOCK (b) == NULL)
155 gdbscm_printf (port, " global");
156 else if (BLOCK_SUPERBLOCK (BLOCK_SUPERBLOCK (b)) == NULL)
157 gdbscm_printf (port, " static");
159 if (BLOCK_FUNCTION (b) != NULL)
160 gdbscm_printf (port, " %s", SYMBOL_PRINT_NAME (BLOCK_FUNCTION (b)));
162 gdbscm_printf (port, " %s-%s",
163 hex_string (BLOCK_START (b)), hex_string (BLOCK_END (b)));
165 scm_puts (">", port);
167 scm_remember_upto_here_1 (self);
169 /* Non-zero means success. */
173 /* Low level routine to create a <gdb:block> object. */
176 bkscm_make_block_smob (void)
178 block_smob *b_smob = (block_smob *)
179 scm_gc_malloc (sizeof (block_smob), block_smob_name);
182 b_smob->block = NULL;
183 b_smob->objfile = NULL;
184 b_scm = scm_new_smob (block_smob_tag, (scm_t_bits) b_smob);
185 gdbscm_init_eqable_gsmob (&b_smob->base, b_scm);
190 /* Returns non-zero if SCM is a <gdb:block> object. */
193 bkscm_is_block (SCM scm)
195 return SCM_SMOB_PREDICATE (block_smob_tag, scm);
198 /* (block? scm) -> boolean */
201 gdbscm_block_p (SCM scm)
203 return scm_from_bool (bkscm_is_block (scm));
206 /* Return the existing object that encapsulates BLOCK, or create a new
207 <gdb:block> object. */
210 bkscm_scm_from_block (const struct block *block, struct objfile *objfile)
213 eqable_gdb_smob **slot;
214 block_smob *b_smob, b_smob_for_lookup;
217 /* If we've already created a gsmob for this block, return it.
218 This makes blocks eq?-able. */
219 htab = bkscm_objfile_block_map (objfile);
220 b_smob_for_lookup.block = block;
221 slot = gdbscm_find_eqable_gsmob_ptr_slot (htab, &b_smob_for_lookup.base);
223 return (*slot)->containing_scm;
225 b_scm = bkscm_make_block_smob ();
226 b_smob = (block_smob *) SCM_SMOB_DATA (b_scm);
227 b_smob->block = block;
228 b_smob->objfile = objfile;
229 gdbscm_fill_eqable_gsmob_ptr_slot (slot, &b_smob->base);
234 /* Returns the <gdb:block> object in SELF.
235 Throws an exception if SELF is not a <gdb:block> object. */
238 bkscm_get_block_arg_unsafe (SCM self, int arg_pos, const char *func_name)
240 SCM_ASSERT_TYPE (bkscm_is_block (self), self, arg_pos, func_name,
246 /* Returns a pointer to the block smob of SELF.
247 Throws an exception if SELF is not a <gdb:block> object. */
250 bkscm_get_block_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
252 SCM b_scm = bkscm_get_block_arg_unsafe (self, arg_pos, func_name);
253 block_smob *b_smob = (block_smob *) SCM_SMOB_DATA (b_scm);
258 /* Returns non-zero if block B_SMOB is valid. */
261 bkscm_is_valid (block_smob *b_smob)
263 return b_smob->block != NULL;
266 /* Returns the block smob in SELF, verifying it's valid.
267 Throws an exception if SELF is not a <gdb:block> object or is invalid. */
270 bkscm_get_valid_block_smob_arg_unsafe (SCM self, int arg_pos,
271 const char *func_name)
274 = bkscm_get_block_smob_arg_unsafe (self, arg_pos, func_name);
276 if (!bkscm_is_valid (b_smob))
278 gdbscm_invalid_object_error (func_name, arg_pos, self,
285 /* Returns the block smob contained in SCM or NULL if SCM is not a
287 If there is an error a <gdb:exception> object is stored in *EXCP. */
290 bkscm_get_valid_block (SCM scm, int arg_pos, const char *func_name, SCM *excp)
294 if (!bkscm_is_block (scm))
296 *excp = gdbscm_make_type_error (func_name, arg_pos, scm,
301 b_smob = (block_smob *) SCM_SMOB_DATA (scm);
302 if (!bkscm_is_valid (b_smob))
304 *excp = gdbscm_make_invalid_object_error (func_name, arg_pos, scm,
312 /* Returns the struct block that is wrapped by BLOCK_SCM.
313 If BLOCK_SCM is not a block, or is an invalid block, then NULL is returned
314 and a <gdb:exception> object is stored in *EXCP. */
317 bkscm_scm_to_block (SCM block_scm, int arg_pos, const char *func_name,
322 b_smob = bkscm_get_valid_block (block_scm, arg_pos, func_name, excp);
325 return b_smob->block;
329 /* Helper function for bkscm_del_objfile_blocks to mark the block
333 bkscm_mark_block_invalid (void **slot, void *info)
335 block_smob *b_smob = (block_smob *) *slot;
337 b_smob->block = NULL;
338 b_smob->objfile = NULL;
342 /* This function is called when an objfile is about to be freed.
343 Invalidate the block as further actions on the block would result
344 in bad data. All access to b_smob->block should be gated by
345 checks to ensure the block is (still) valid. */
348 bkscm_del_objfile_blocks (struct objfile *objfile, void *datum)
350 htab_t htab = (htab_t) datum;
354 htab_traverse_noresize (htab, bkscm_mark_block_invalid, NULL);
361 /* (block-valid? <gdb:block>) -> boolean
362 Returns #t if SELF still exists in GDB. */
365 gdbscm_block_valid_p (SCM self)
368 = bkscm_get_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
370 return scm_from_bool (bkscm_is_valid (b_smob));
373 /* (block-start <gdb:block>) -> address */
376 gdbscm_block_start (SCM self)
379 = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
380 const struct block *block = b_smob->block;
382 return gdbscm_scm_from_ulongest (BLOCK_START (block));
385 /* (block-end <gdb:block>) -> address */
388 gdbscm_block_end (SCM self)
391 = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
392 const struct block *block = b_smob->block;
394 return gdbscm_scm_from_ulongest (BLOCK_END (block));
397 /* (block-function <gdb:block>) -> <gdb:symbol> */
400 gdbscm_block_function (SCM self)
403 = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
404 const struct block *block = b_smob->block;
407 sym = BLOCK_FUNCTION (block);
410 return syscm_scm_from_symbol (sym);
414 /* (block-superblock <gdb:block>) -> <gdb:block> */
417 gdbscm_block_superblock (SCM self)
420 = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
421 const struct block *block = b_smob->block;
422 const struct block *super_block;
424 super_block = BLOCK_SUPERBLOCK (block);
427 return bkscm_scm_from_block (super_block, b_smob->objfile);
431 /* (block-global-block <gdb:block>) -> <gdb:block>
432 Returns the global block associated to this block. */
435 gdbscm_block_global_block (SCM self)
438 = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
439 const struct block *block = b_smob->block;
440 const struct block *global_block;
442 global_block = block_global_block (block);
444 return bkscm_scm_from_block (global_block, b_smob->objfile);
447 /* (block-static-block <gdb:block>) -> <gdb:block>
448 Returns the static block associated to this block.
449 Returns #f if we cannot get the static block (this is the global block). */
452 gdbscm_block_static_block (SCM self)
455 = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
456 const struct block *block = b_smob->block;
457 const struct block *static_block;
459 if (BLOCK_SUPERBLOCK (block) == NULL)
462 static_block = block_static_block (block);
464 return bkscm_scm_from_block (static_block, b_smob->objfile);
467 /* (block-global? <gdb:block>) -> boolean
468 Returns #t if this block object is a global block. */
471 gdbscm_block_global_p (SCM self)
474 = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
475 const struct block *block = b_smob->block;
477 return scm_from_bool (BLOCK_SUPERBLOCK (block) == NULL);
480 /* (block-static? <gdb:block>) -> boolean
481 Returns #t if this block object is a static block. */
484 gdbscm_block_static_p (SCM self)
487 = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
488 const struct block *block = b_smob->block;
490 if (BLOCK_SUPERBLOCK (block) != NULL
491 && BLOCK_SUPERBLOCK (BLOCK_SUPERBLOCK (block)) == NULL)
496 /* (block-symbols <gdb:block>) -> list of <gdb:symbol objects
497 Returns a list of symbols of the block. */
500 gdbscm_block_symbols (SCM self)
503 = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
504 const struct block *block = b_smob->block;
505 struct block_iterator iter;
511 sym = block_iterator_first (block, &iter);
515 SCM s_scm = syscm_scm_from_symbol (sym);
517 result = scm_cons (s_scm, result);
518 sym = block_iterator_next (&iter);
521 return scm_reverse_x (result, SCM_EOL);
524 /* The <gdb:block-symbols-iterator> object,
525 for iterating over all symbols in a block. */
527 /* The smob "print" function for <gdb:block-symbols-iterator>. */
530 bkscm_print_block_syms_progress_smob (SCM self, SCM port,
531 scm_print_state *pstate)
533 block_syms_progress_smob *i_smob
534 = (block_syms_progress_smob *) SCM_SMOB_DATA (self);
536 gdbscm_printf (port, "#<%s", block_syms_progress_smob_name);
538 if (i_smob->initialized_p)
540 switch (i_smob->iter.which)
545 struct compunit_symtab *cust;
547 gdbscm_printf (port, " %s",
548 i_smob->iter.which == GLOBAL_BLOCK
549 ? "global" : "static");
550 if (i_smob->iter.idx != -1)
551 gdbscm_printf (port, " @%d", i_smob->iter.idx);
552 cust = (i_smob->iter.idx == -1
553 ? i_smob->iter.d.compunit_symtab
554 : i_smob->iter.d.compunit_symtab->includes[i_smob->iter.idx]);
555 gdbscm_printf (port, " %s",
556 symtab_to_filename_for_display
557 (compunit_primary_filetab (cust)));
560 case FIRST_LOCAL_BLOCK:
561 gdbscm_printf (port, " single block");
566 gdbscm_printf (port, " !initialized");
568 scm_puts (">", port);
570 scm_remember_upto_here_1 (self);
572 /* Non-zero means success. */
576 /* Low level routine to create a <gdb:block-symbols-progress> object. */
579 bkscm_make_block_syms_progress_smob (void)
581 block_syms_progress_smob *i_smob = (block_syms_progress_smob *)
582 scm_gc_malloc (sizeof (block_syms_progress_smob),
583 block_syms_progress_smob_name);
586 memset (&i_smob->iter, 0, sizeof (i_smob->iter));
587 i_smob->initialized_p = 0;
588 smob = scm_new_smob (block_syms_progress_smob_tag, (scm_t_bits) i_smob);
589 gdbscm_init_gsmob (&i_smob->base);
594 /* Returns non-zero if SCM is a <gdb:block-symbols-progress> object. */
597 bkscm_is_block_syms_progress (SCM scm)
599 return SCM_SMOB_PREDICATE (block_syms_progress_smob_tag, scm);
602 /* (block-symbols-progress? scm) -> boolean */
605 bkscm_block_syms_progress_p (SCM scm)
607 return scm_from_bool (bkscm_is_block_syms_progress (scm));
610 /* (make-block-symbols-iterator <gdb:block>) -> <gdb:iterator>
611 Return a <gdb:iterator> object for iterating over the symbols of SELF. */
614 gdbscm_make_block_syms_iter (SCM self)
616 /* Call for side effects. */
617 bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
620 progress = bkscm_make_block_syms_progress_smob ();
622 iter = gdbscm_make_iterator (self, progress, bkscm_next_symbol_x_proc);
627 /* Returns the next symbol in the iteration through the block's dictionary,
628 or (end-of-iteration).
629 This is the iterator_smob.next_x method. */
632 gdbscm_block_next_symbol_x (SCM self)
634 SCM progress, iter_scm, block_scm;
635 iterator_smob *iter_smob;
637 const struct block *block;
638 block_syms_progress_smob *p_smob;
641 iter_scm = itscm_get_iterator_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
642 iter_smob = (iterator_smob *) SCM_SMOB_DATA (iter_scm);
644 block_scm = itscm_iterator_smob_object (iter_smob);
645 b_smob = bkscm_get_valid_block_smob_arg_unsafe (block_scm,
646 SCM_ARG1, FUNC_NAME);
647 block = b_smob->block;
649 progress = itscm_iterator_smob_progress (iter_smob);
651 SCM_ASSERT_TYPE (bkscm_is_block_syms_progress (progress),
652 progress, SCM_ARG1, FUNC_NAME,
653 block_syms_progress_smob_name);
654 p_smob = (block_syms_progress_smob *) SCM_SMOB_DATA (progress);
656 if (!p_smob->initialized_p)
658 sym = block_iterator_first (block, &p_smob->iter);
659 p_smob->initialized_p = 1;
662 sym = block_iterator_next (&p_smob->iter);
665 return gdbscm_end_of_iteration ();
667 return syscm_scm_from_symbol (sym);
670 /* (lookup-block address) -> <gdb:block>
671 Returns the innermost lexical block containing the specified pc value,
672 or #f if there is none. */
675 gdbscm_lookup_block (SCM pc_scm)
678 const struct block *block = NULL;
679 struct compunit_symtab *cust = NULL;
681 gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "U", pc_scm, &pc);
685 cust = find_pc_compunit_symtab (pc);
687 if (cust != NULL && COMPUNIT_OBJFILE (cust) != NULL)
688 block = block_for_pc (pc);
690 CATCH (except, RETURN_MASK_ALL)
692 GDBSCM_HANDLE_GDB_EXCEPTION (except);
696 if (cust == NULL || COMPUNIT_OBJFILE (cust) == NULL)
698 gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, pc_scm,
699 _("cannot locate object file for block"));
703 return bkscm_scm_from_block (block, COMPUNIT_OBJFILE (cust));
707 /* Initialize the Scheme block support. */
709 static const scheme_function block_functions[] =
711 { "block?", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_p),
713 Return #t if the object is a <gdb:block> object." },
715 { "block-valid?", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_valid_p),
717 Return #t if the block is valid.\n\
718 A block becomes invalid when its objfile is freed." },
720 { "block-start", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_start),
722 Return the start address of the block." },
724 { "block-end", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_end),
726 Return the end address of the block." },
728 { "block-function", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_function),
730 Return the gdb:symbol object of the function containing the block\n\
731 or #f if the block does not live in any function." },
733 { "block-superblock", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_superblock),
735 Return the superblock (parent block) of the block." },
737 { "block-global-block", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_global_block),
739 Return the global block of the block." },
741 { "block-static-block", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_static_block),
743 Return the static block of the block." },
745 { "block-global?", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_global_p),
747 Return #t if block is a global block." },
749 { "block-static?", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_static_p),
751 Return #t if block is a static block." },
753 { "block-symbols", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_symbols),
755 Return a list of all symbols (as <gdb:symbol> objects) in the block." },
757 { "make-block-symbols-iterator", 1, 0, 0,
758 as_a_scm_t_subr (gdbscm_make_block_syms_iter),
760 Return a <gdb:iterator> object for iterating over all symbols in the block." },
762 { "block-symbols-progress?", 1, 0, 0,
763 as_a_scm_t_subr (bkscm_block_syms_progress_p),
765 Return #t if the object is a <gdb:block-symbols-progress> object." },
767 { "lookup-block", 1, 0, 0, as_a_scm_t_subr (gdbscm_lookup_block),
769 Return the innermost GDB block containing the address or #f if none found.\n\
772 address: the address to lookup" },
778 gdbscm_initialize_blocks (void)
781 = gdbscm_make_smob_type (block_smob_name, sizeof (block_smob));
782 scm_set_smob_free (block_smob_tag, bkscm_free_block_smob);
783 scm_set_smob_print (block_smob_tag, bkscm_print_block_smob);
785 block_syms_progress_smob_tag
786 = gdbscm_make_smob_type (block_syms_progress_smob_name,
787 sizeof (block_syms_progress_smob));
788 scm_set_smob_print (block_syms_progress_smob_tag,
789 bkscm_print_block_syms_progress_smob);
791 gdbscm_define_functions (block_functions, 1);
793 /* This function is "private". */
794 bkscm_next_symbol_x_proc
795 = scm_c_define_gsubr ("%block-next-symbol!", 1, 0, 0,
796 as_a_scm_t_subr (gdbscm_block_next_symbol_x));
797 scm_set_procedure_property_x (bkscm_next_symbol_x_proc,
798 gdbscm_documentation_symbol,
799 gdbscm_scm_from_c_string ("\
800 Internal function to assist the block symbols iterator."));
802 /* Register an objfile "free" callback so we can properly
803 invalidate blocks when an object file is about to be deleted. */
804 bkscm_objfile_data_key
805 = register_objfile_data_with_cleanup (NULL, bkscm_del_objfile_blocks);