/* Scheme interface to blocks. Copyright (C) 2008-2014 Free Software Foundation, Inc. This file is part of GDB. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see <http://www.gnu.org/licenses/>. */ /* See README file in this directory for implementation notes, coding conventions, et.al. */ #include "defs.h" #include "block.h" #include "dictionary.h" #include "objfiles.h" #include "source.h" #include "symtab.h" #include "guile-internal.h" /* A smob describing a gdb block. */ typedef struct _block_smob { /* This always appears first. We want blocks to be eq?-able. And we need to be able to invalidate blocks when the associated objfile is deleted. */ eqable_gdb_smob base; /* The GDB block structure that represents a frame's code block. */ const struct block *block; /* The backing object file. There is no direct relationship in GDB between a block and an object file. When a block is created also store a pointer to the object file for later use. */ struct objfile *objfile; } block_smob; /* To iterate over block symbols from Scheme we need to store struct block_iterator somewhere. This is stored in the "progress" field of <gdb:iterator>. We store the block object in iterator_smob.object, so we don't store it here. Remember: While iterating over block symbols, you must continually check whether the block is still valid. */ typedef struct { /* This always appears first. */ gdb_smob base; /* The iterator for that block. */ struct block_iterator iter; /* Has the iterator been initialized flag. */ int initialized_p; } block_syms_progress_smob; static const char block_smob_name[] = "gdb:block"; static const char block_syms_progress_smob_name[] = "gdb:block-symbols-iterator"; /* The tag Guile knows the block smobs by. */ static scm_t_bits block_smob_tag; static scm_t_bits block_syms_progress_smob_tag; /* The "next!" block syms iterator method. */ static SCM bkscm_next_symbol_x_proc; static const struct objfile_data *bkscm_objfile_data_key; /* Administrivia for block smobs. */ /* Helper function to hash a block_smob. */ static hashval_t bkscm_hash_block_smob (const void *p) { const block_smob *b_smob = p; return htab_hash_pointer (b_smob->block); } /* Helper function to compute equality of block_smobs. */ static int bkscm_eq_block_smob (const void *ap, const void *bp) { const block_smob *a = ap; const block_smob *b = bp; return (a->block == b->block && a->block != NULL); } /* Return the struct block pointer -> SCM mapping table. It is created if necessary. */ static htab_t bkscm_objfile_block_map (struct objfile *objfile) { htab_t htab = objfile_data (objfile, bkscm_objfile_data_key); if (htab == NULL) { htab = gdbscm_create_eqable_gsmob_ptr_map (bkscm_hash_block_smob, bkscm_eq_block_smob); set_objfile_data (objfile, bkscm_objfile_data_key, htab); } return htab; } /* The smob "free" function for <gdb:block>. */ static size_t bkscm_free_block_smob (SCM self) { block_smob *b_smob = (block_smob *) SCM_SMOB_DATA (self); if (b_smob->block != NULL) { htab_t htab = bkscm_objfile_block_map (b_smob->objfile); gdbscm_clear_eqable_gsmob_ptr_slot (htab, &b_smob->base); } /* Not necessary, done to catch bugs. */ b_smob->block = NULL; b_smob->objfile = NULL; return 0; } /* The smob "print" function for <gdb:block>. */ static int bkscm_print_block_smob (SCM self, SCM port, scm_print_state *pstate) { block_smob *b_smob = (block_smob *) SCM_SMOB_DATA (self); const struct block *b = b_smob->block; gdbscm_printf (port, "#<%s", block_smob_name); if (BLOCK_SUPERBLOCK (b) == NULL) gdbscm_printf (port, " global"); else if (BLOCK_SUPERBLOCK (BLOCK_SUPERBLOCK (b)) == NULL) gdbscm_printf (port, " static"); if (BLOCK_FUNCTION (b) != NULL) gdbscm_printf (port, " %s", SYMBOL_PRINT_NAME (BLOCK_FUNCTION (b))); gdbscm_printf (port, " %s-%s", hex_string (BLOCK_START (b)), hex_string (BLOCK_END (b))); scm_puts (">", port); scm_remember_upto_here_1 (self); /* Non-zero means success. */ return 1; } /* Low level routine to create a <gdb:block> object. */ static SCM bkscm_make_block_smob (void) { block_smob *b_smob = (block_smob *) scm_gc_malloc (sizeof (block_smob), block_smob_name); SCM b_scm; b_smob->block = NULL; b_smob->objfile = NULL; b_scm = scm_new_smob (block_smob_tag, (scm_t_bits) b_smob); gdbscm_init_eqable_gsmob (&b_smob->base, b_scm); return b_scm; } /* Returns non-zero if SCM is a <gdb:block> object. */ static int bkscm_is_block (SCM scm) { return SCM_SMOB_PREDICATE (block_smob_tag, scm); } /* (block? scm) -> boolean */ static SCM gdbscm_block_p (SCM scm) { return scm_from_bool (bkscm_is_block (scm)); } /* Return the existing object that encapsulates BLOCK, or create a new <gdb:block> object. */ SCM bkscm_scm_from_block (const struct block *block, struct objfile *objfile) { htab_t htab; eqable_gdb_smob **slot; block_smob *b_smob, b_smob_for_lookup; SCM b_scm; /* If we've already created a gsmob for this block, return it. This makes blocks eq?-able. */ htab = bkscm_objfile_block_map (objfile); b_smob_for_lookup.block = block; slot = gdbscm_find_eqable_gsmob_ptr_slot (htab, &b_smob_for_lookup.base); if (*slot != NULL) return (*slot)->containing_scm; b_scm = bkscm_make_block_smob (); b_smob = (block_smob *) SCM_SMOB_DATA (b_scm); b_smob->block = block; b_smob->objfile = objfile; gdbscm_fill_eqable_gsmob_ptr_slot (slot, &b_smob->base); return b_scm; } /* Returns the <gdb:block> object in SELF. Throws an exception if SELF is not a <gdb:block> object. */ static SCM bkscm_get_block_arg_unsafe (SCM self, int arg_pos, const char *func_name) { SCM_ASSERT_TYPE (bkscm_is_block (self), self, arg_pos, func_name, block_smob_name); return self; } /* Returns a pointer to the block smob of SELF. Throws an exception if SELF is not a <gdb:block> object. */ static block_smob * bkscm_get_block_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name) { SCM b_scm = bkscm_get_block_arg_unsafe (self, arg_pos, func_name); block_smob *b_smob = (block_smob *) SCM_SMOB_DATA (b_scm); return b_smob; } /* Returns non-zero if block B_SMOB is valid. */ static int bkscm_is_valid (block_smob *b_smob) { return b_smob->block != NULL; } /* Returns the block smob in SELF, verifying it's valid. Throws an exception if SELF is not a <gdb:block> object or is invalid. */ static block_smob * bkscm_get_valid_block_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name) { block_smob *b_smob = bkscm_get_block_smob_arg_unsafe (self, arg_pos, func_name); if (!bkscm_is_valid (b_smob)) { gdbscm_invalid_object_error (func_name, arg_pos, self, _("<gdb:block>")); } return b_smob; } /* Returns the block smob contained in SCM or NULL if SCM is not a <gdb:block> object. If there is an error a <gdb:exception> object is stored in *EXCP. */ static block_smob * bkscm_get_valid_block (SCM scm, int arg_pos, const char *func_name, SCM *excp) { block_smob *b_smob; if (!bkscm_is_block (scm)) { *excp = gdbscm_make_type_error (func_name, arg_pos, scm, block_smob_name); return NULL; } b_smob = (block_smob *) SCM_SMOB_DATA (scm); if (!bkscm_is_valid (b_smob)) { *excp = gdbscm_make_invalid_object_error (func_name, arg_pos, scm, _("<gdb:block>")); return NULL; } return b_smob; } /* Returns the struct block that is wrapped by BLOCK_SCM. If BLOCK_SCM is not a block, or is an invalid block, then NULL is returned and a <gdb:exception> object is stored in *EXCP. */ const struct block * bkscm_scm_to_block (SCM block_scm, int arg_pos, const char *func_name, SCM *excp) { block_smob *b_smob; b_smob = bkscm_get_valid_block (block_scm, arg_pos, func_name, excp); if (b_smob != NULL) return b_smob->block; return NULL; } /* Helper function for bkscm_del_objfile_blocks to mark the block as invalid. */ static int bkscm_mark_block_invalid (void **slot, void *info) { block_smob *b_smob = (block_smob *) *slot; b_smob->block = NULL; b_smob->objfile = NULL; return 1; } /* This function is called when an objfile is about to be freed. Invalidate the block as further actions on the block would result in bad data. All access to b_smob->block should be gated by checks to ensure the block is (still) valid. */ static void bkscm_del_objfile_blocks (struct objfile *objfile, void *datum) { htab_t htab = datum; if (htab != NULL) { htab_traverse_noresize (htab, bkscm_mark_block_invalid, NULL); htab_delete (htab); } } /* Block methods. */ /* (block-valid? <gdb:block>) -> boolean Returns #t if SELF still exists in GDB. */ static SCM gdbscm_block_valid_p (SCM self) { block_smob *b_smob = bkscm_get_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); return scm_from_bool (bkscm_is_valid (b_smob)); } /* (block-start <gdb:block>) -> address */ static SCM gdbscm_block_start (SCM self) { block_smob *b_smob = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); const struct block *block = b_smob->block; return gdbscm_scm_from_ulongest (BLOCK_START (block)); } /* (block-end <gdb:block>) -> address */ static SCM gdbscm_block_end (SCM self) { block_smob *b_smob = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); const struct block *block = b_smob->block; return gdbscm_scm_from_ulongest (BLOCK_END (block)); } /* (block-function <gdb:block>) -> <gdb:symbol> */ static SCM gdbscm_block_function (SCM self) { block_smob *b_smob = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); const struct block *block = b_smob->block; struct symbol *sym; sym = BLOCK_FUNCTION (block); if (sym != NULL) return syscm_scm_from_symbol (sym); return SCM_BOOL_F; } /* (block-superblock <gdb:block>) -> <gdb:block> */ static SCM gdbscm_block_superblock (SCM self) { block_smob *b_smob = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); const struct block *block = b_smob->block; const struct block *super_block; super_block = BLOCK_SUPERBLOCK (block); if (super_block) return bkscm_scm_from_block (super_block, b_smob->objfile); return SCM_BOOL_F; } /* (block-global-block <gdb:block>) -> <gdb:block> Returns the global block associated to this block. */ static SCM gdbscm_block_global_block (SCM self) { block_smob *b_smob = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); const struct block *block = b_smob->block; const struct block *global_block; global_block = block_global_block (block); return bkscm_scm_from_block (global_block, b_smob->objfile); } /* (block-static-block <gdb:block>) -> <gdb:block> Returns the static block associated to this block. Returns #f if we cannot get the static block (this is the global block). */ static SCM gdbscm_block_static_block (SCM self) { block_smob *b_smob = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); const struct block *block = b_smob->block; const struct block *static_block; if (BLOCK_SUPERBLOCK (block) == NULL) return SCM_BOOL_F; static_block = block_static_block (block); return bkscm_scm_from_block (static_block, b_smob->objfile); } /* (block-global? <gdb:block>) -> boolean Returns #t if this block object is a global block. */ static SCM gdbscm_block_global_p (SCM self) { block_smob *b_smob = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); const struct block *block = b_smob->block; return scm_from_bool (BLOCK_SUPERBLOCK (block) == NULL); } /* (block-static? <gdb:block>) -> boolean Returns #t if this block object is a static block. */ static SCM gdbscm_block_static_p (SCM self) { block_smob *b_smob = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); const struct block *block = b_smob->block; if (BLOCK_SUPERBLOCK (block) != NULL && BLOCK_SUPERBLOCK (BLOCK_SUPERBLOCK (block)) == NULL) return SCM_BOOL_T; return SCM_BOOL_F; } /* (block-symbols <gdb:block>) -> list of <gdb:symbol objects Returns a list of symbols of the block. */ static SCM gdbscm_block_symbols (SCM self) { block_smob *b_smob = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); const struct block *block = b_smob->block; struct block_iterator iter; struct symbol *sym; SCM result; result = SCM_EOL; sym = block_iterator_first (block, &iter); while (sym != NULL) { SCM s_scm = syscm_scm_from_symbol (sym); result = scm_cons (s_scm, result); sym = block_iterator_next (&iter); } return scm_reverse_x (result, SCM_EOL); } /* The <gdb:block-symbols-iterator> object, for iterating over all symbols in a block. */ /* The smob "print" function for <gdb:block-symbols-iterator>. */ static int bkscm_print_block_syms_progress_smob (SCM self, SCM port, scm_print_state *pstate) { block_syms_progress_smob *i_smob = (block_syms_progress_smob *) SCM_SMOB_DATA (self); gdbscm_printf (port, "#<%s", block_syms_progress_smob_name); if (i_smob->initialized_p) { switch (i_smob->iter.which) { case GLOBAL_BLOCK: case STATIC_BLOCK: { struct symtab *s; gdbscm_printf (port, " %s", i_smob->iter.which == GLOBAL_BLOCK ? "global" : "static"); if (i_smob->iter.idx != -1) gdbscm_printf (port, " @%d", i_smob->iter.idx); s = (i_smob->iter.idx == -1 ? i_smob->iter.d.symtab : i_smob->iter.d.symtab->includes[i_smob->iter.idx]); gdbscm_printf (port, " %s", symtab_to_filename_for_display (s)); break; } case FIRST_LOCAL_BLOCK: gdbscm_printf (port, " single block"); break; } } else gdbscm_printf (port, " !initialized"); scm_puts (">", port); scm_remember_upto_here_1 (self); /* Non-zero means success. */ return 1; } /* Low level routine to create a <gdb:block-symbols-progress> object. */ static SCM bkscm_make_block_syms_progress_smob (void) { block_syms_progress_smob *i_smob = (block_syms_progress_smob *) scm_gc_malloc (sizeof (block_syms_progress_smob), block_syms_progress_smob_name); SCM smob; memset (&i_smob->iter, 0, sizeof (i_smob->iter)); i_smob->initialized_p = 0; smob = scm_new_smob (block_syms_progress_smob_tag, (scm_t_bits) i_smob); gdbscm_init_gsmob (&i_smob->base); return smob; } /* Returns non-zero if SCM is a <gdb:block-symbols-progress> object. */ static int bkscm_is_block_syms_progress (SCM scm) { return SCM_SMOB_PREDICATE (block_syms_progress_smob_tag, scm); } /* (block-symbols-progress? scm) -> boolean */ static SCM bkscm_block_syms_progress_p (SCM scm) { return scm_from_bool (bkscm_is_block_syms_progress (scm)); } /* (make-block-symbols-iterator <gdb:block>) -> <gdb:iterator> Return a <gdb:iterator> object for iterating over the symbols of SELF. */ static SCM gdbscm_make_block_syms_iter (SCM self) { block_smob *b_smob = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); const struct block *block = b_smob->block; SCM progress, iter; progress = bkscm_make_block_syms_progress_smob (); iter = gdbscm_make_iterator (self, progress, bkscm_next_symbol_x_proc); return iter; } /* Returns the next symbol in the iteration through the block's dictionary, or (end-of-iteration). This is the iterator_smob.next_x method. */ static SCM gdbscm_block_next_symbol_x (SCM self) { SCM progress, iter_scm, block_scm; iterator_smob *iter_smob; block_smob *b_smob; const struct block *block; block_syms_progress_smob *p_smob; struct symbol *sym; iter_scm = itscm_get_iterator_arg_unsafe (self, SCM_ARG1, FUNC_NAME); iter_smob = (iterator_smob *) SCM_SMOB_DATA (iter_scm); block_scm = itscm_iterator_smob_object (iter_smob); b_smob = bkscm_get_valid_block_smob_arg_unsafe (block_scm, SCM_ARG1, FUNC_NAME); block = b_smob->block; progress = itscm_iterator_smob_progress (iter_smob); SCM_ASSERT_TYPE (bkscm_is_block_syms_progress (progress), progress, SCM_ARG1, FUNC_NAME, block_syms_progress_smob_name); p_smob = (block_syms_progress_smob *) SCM_SMOB_DATA (progress); if (!p_smob->initialized_p) { sym = block_iterator_first (block, &p_smob->iter); p_smob->initialized_p = 1; } else sym = block_iterator_next (&p_smob->iter); if (sym == NULL) return gdbscm_end_of_iteration (); return syscm_scm_from_symbol (sym); } /* (lookup-block address) -> <gdb:block> Returns the innermost lexical block containing the specified pc value, or #f if there is none. */ static SCM gdbscm_lookup_block (SCM pc_scm) { CORE_ADDR pc; const struct block *block = NULL; struct obj_section *section = NULL; struct symtab *symtab = NULL; volatile struct gdb_exception except; gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "U", pc_scm, &pc); TRY_CATCH (except, RETURN_MASK_ALL) { section = find_pc_mapped_section (pc); symtab = find_pc_sect_symtab (pc, section); if (symtab != NULL && symtab->objfile != NULL) block = block_for_pc (pc); } GDBSCM_HANDLE_GDB_EXCEPTION (except); if (symtab == NULL || symtab->objfile == NULL) { gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, pc_scm, _("cannot locate object file for block")); } if (block != NULL) return bkscm_scm_from_block (block, symtab->objfile); return SCM_BOOL_F; } /* Initialize the Scheme block support. */ static const scheme_function block_functions[] = { { "block?", 1, 0, 0, gdbscm_block_p, "\ Return #t if the object is a <gdb:block> object." }, { "block-valid?", 1, 0, 0, gdbscm_block_valid_p, "\ Return #t if the block is valid.\n\ A block becomes invalid when its objfile is freed." }, { "block-start", 1, 0, 0, gdbscm_block_start, "\ Return the start address of the block." }, { "block-end", 1, 0, 0, gdbscm_block_end, "\ Return the end address of the block." }, { "block-function", 1, 0, 0, gdbscm_block_function, "\ Return the gdb:symbol object of the function containing the block\n\ or #f if the block does not live in any function." }, { "block-superblock", 1, 0, 0, gdbscm_block_superblock, "\ Return the superblock (parent block) of the block." }, { "block-global-block", 1, 0, 0, gdbscm_block_global_block, "\ Return the global block of the block." }, { "block-static-block", 1, 0, 0, gdbscm_block_static_block, "\ Return the static block of the block." }, { "block-global?", 1, 0, 0, gdbscm_block_global_p, "\ Return #t if block is a global block." }, { "block-static?", 1, 0, 0, gdbscm_block_static_p, "\ Return #t if block is a static block." }, { "block-symbols", 1, 0, 0, gdbscm_block_symbols, "\ Return a list of all symbols (as <gdb:symbol> objects) in the block." }, { "make-block-symbols-iterator", 1, 0, 0, gdbscm_make_block_syms_iter, "\ Return a <gdb:iterator> object for iterating over all symbols in the block." }, { "block-symbols-progress?", 1, 0, 0, bkscm_block_syms_progress_p, "\ Return #t if the object is a <gdb:block-symbols-progress> object." }, { "lookup-block", 1, 0, 0, gdbscm_lookup_block, "\ Return the innermost GDB block containing the address or #f if none found.\n\ \n\ Arguments:\n\ address: the address to lookup" }, END_FUNCTIONS }; void gdbscm_initialize_blocks (void) { block_smob_tag = gdbscm_make_smob_type (block_smob_name, sizeof (block_smob)); scm_set_smob_free (block_smob_tag, bkscm_free_block_smob); scm_set_smob_print (block_smob_tag, bkscm_print_block_smob); block_syms_progress_smob_tag = gdbscm_make_smob_type (block_syms_progress_smob_name, sizeof (block_syms_progress_smob)); scm_set_smob_print (block_syms_progress_smob_tag, bkscm_print_block_syms_progress_smob); gdbscm_define_functions (block_functions, 1); /* This function is "private". */ bkscm_next_symbol_x_proc = scm_c_define_gsubr ("%block-next-symbol!", 1, 0, 0, gdbscm_block_next_symbol_x); scm_set_procedure_property_x (bkscm_next_symbol_x_proc, gdbscm_documentation_symbol, gdbscm_scm_from_c_string ("\ Internal function to assist the block symbols iterator.")); /* Register an objfile "free" callback so we can properly invalidate blocks when an object file is about to be deleted. */ bkscm_objfile_data_key = register_objfile_data_with_cleanup (NULL, bkscm_del_objfile_blocks); }