>From a8a8ceb973b87b24d2e7317728c3c1358763bab6 Mon Sep 17 00:00:00 2001 From: Daniel Colascione Date: Wed, 2 Apr 2014 17:18:08 -0700 Subject: [PATCH] Add GC bug investigation code Conflicts: lisp/ChangeLog lisp/subr.el src/ChangeLog --- lisp/subr.el | 51 ++++++++++++++++------------- src/alloc.c | 105 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/data.c | 5 +++ src/lisp.h | 3 ++ 4 files changed, 141 insertions(+), 23 deletions(-) diff --git a/lisp/subr.el b/lisp/subr.el index e4350bf..177e144 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -4290,29 +4290,34 @@ lookup sequence then continues." ;; Don't use letrec, because equal (in add/remove-hook) would get trapped ;; in a cycle. (fset clearfun - (lambda () - (with-demoted-errors "set-transient-map PCH: %S" - (unless (cond - ((not (eq map (cadr overriding-terminal-local-map))) - ;; There's presumably some other transient-map in - ;; effect. Wait for that one to terminate before we - ;; remove ourselves. - ;; For example, if isearch and C-u both use transient - ;; maps, then the lifetime of the C-u should be nested - ;; within isearch's, so the pre-command-hook of - ;; isearch should be suspended during the C-u one so - ;; we don't exit isearch just because we hit 1 after - ;; C-u and that 1 exits isearch whereas it doesn't - ;; exit C-u. - t) - ((null keep-pred) nil) - ((eq t keep-pred) - (eq this-command - (lookup-key map (this-command-keys-vector)))) - (t (funcall keep-pred))) - (internal-pop-keymap map 'overriding-terminal-local-map) - (remove-hook 'pre-command-hook clearfun) - (when on-exit (funcall on-exit)))))) + (suspicious-object + (lambda () + (with-demoted-errors "set-transient-map PCH: %S" + (unless (cond + ((not (eq map (cadr overriding-terminal-local-map))) + ;; There's presumably some other transient-map in + ;; effect. Wait for that one to terminate before we + ;; remove ourselves. + ;; For example, if isearch and C-u both use transient + ;; maps, then the lifetime of the C-u should be nested + ;; within isearch's, so the pre-command-hook of + ;; isearch should be suspended during the C-u one so + ;; we don't exit isearch just because we hit 1 after + ;; C-u and that 1 exits isearch whereas it doesn't + ;; exit C-u. + t) + ((null keep-pred) nil) + ((eq t keep-pred) + (eq this-command + (lookup-key map (this-command-keys-vector)))) + (t (funcall keep-pred))) + (internal-pop-keymap map 'overriding-terminal-local-map) + (remove-hook 'pre-command-hook clearfun) + (when on-exit (funcall on-exit)) + ;; Comment out the fset if you want to debug the GC bug. +;;; (fset clearfun nil) +;;; (set clearfun nil) + ))))) (add-hook 'pre-command-hook clearfun) (internal-push-keymap map 'overriding-terminal-local-map))) diff --git a/src/alloc.c b/src/alloc.c index 62c3bee..5732d16 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -48,6 +48,10 @@ along with GNU Emacs. If not, see . */ #include +#ifdef HAVE_EXECINFO_H +#include /* For backtrace */ +#endif + #if (defined ENABLE_CHECKING \ && defined HAVE_VALGRIND_VALGRIND_H \ && !defined USE_VALGRIND) @@ -192,6 +196,36 @@ static ptrdiff_t pure_bytes_used_non_lisp; const char *pending_malloc_warning; +#if 0 /* Normally, pointer sanity only on request... */ +#ifdef ENABLE_CHECKING +#define SUSPICIOUS_OBJECT_CHECKING 1 +#endif +#endif + +/* ... but unconditionally use SUSPICIOUS_OBJECT_CHECKING while the GC + bug is unresolved. */ +#define SUSPICIOUS_OBJECT_CHECKING 1 + +#ifdef SUSPICIOUS_OBJECT_CHECKING +struct suspicious_free_record { + void* suspicious_object; +#ifdef HAVE_EXECINFO_H + void* backtrace[128]; +#endif +}; +static void* suspicious_objects[32]; +static int suspicious_object_index; +struct suspicious_free_record suspicious_free_history[64]; +static int suspicious_free_history_index; +/* Find the first currently-monitored suspicious pointer in range + [begin,end) or NULL if no such pointer exists. */ +static void* find_suspicious_object_in_range (void* begin, void* end); +static void detect_suspicious_free (void* ptr); +#else +#define find_suspicious_object_in_range(begin, end) NULL +#define detect_suspicious_free(ptr) (void) +#endif + /* Maximum amount of C stack to save when a GC happens. */ #ifndef MAX_SAVE_STACK @@ -2914,6 +2948,7 @@ vector_nbytes (struct Lisp_Vector *v) static void cleanup_vector (struct Lisp_Vector *vector) { + detect_suspicious_free (vector); if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FONT) && ((vector->header.size & PSEUDOVECTOR_SIZE_MASK) == FONT_OBJECT_MAX)) @@ -3074,6 +3109,9 @@ allocate_vectorlike (ptrdiff_t len) mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); #endif + if (find_suspicious_object_in_range (p, (char*)p + nbytes)) + emacs_abort (); + consing_since_gc += nbytes; vector_cells_consed += len; } @@ -3773,6 +3811,7 @@ refill_memory_reserve (void) Vmemory_full = Qnil; #endif } + /************************************************************************ C Stack Marking @@ -6763,6 +6802,71 @@ which_symbols (Lisp_Object obj, EMACS_INT find_max) return found; } +#ifdef SUSPICIOUS_OBJECT_CHECKING + +static void* +find_suspicious_object_in_range (void* begin, void* end) +{ + char* begin_a = begin; + char* end_a = end; + int i; + + for (i = 0; i < EARRAYSIZE (suspicious_objects); ++i) { + char* suspicious_object = suspicious_objects[i]; + if (begin_a <= suspicious_object && suspicious_object < end_a) + return suspicious_object; + } + + return NULL; +} + +static void +detect_suspicious_free (void* ptr) +{ + int i; + struct suspicious_free_record* rec; + + eassert (ptr != NULL); + + for (i = 0; i < EARRAYSIZE (suspicious_objects); ++i) + if (suspicious_objects[i] == ptr) + { + rec = &suspicious_free_history[suspicious_free_history_index++]; + if (suspicious_free_history_index == + EARRAYSIZE (suspicious_free_history)) + { + suspicious_free_history_index = 0; + } + + memset (rec, 0, sizeof (rec)); + rec->suspicious_object = ptr; +#ifdef HAVE_EXECINFO_H + backtrace (&rec->backtrace[0], EARRAYSIZE (rec->backtrace)); +#endif + suspicious_objects[i] = NULL; + } +} + +#endif /* SUSPICIOUS_OBJECT_CHECKING */ + +DEFUN ("suspicious-object", Fsuspicious_object, Ssuspicious_object, 1, 1, 0, + doc: /* Return OBJ, maybe marking it for extra scrutiny. +If Emacs is compiled with suspicous object checking, capture +a stack trace when OBJ is freed in order to help track down +garbage collection bugs. Otherwise, do nothing and return OBJ. */) + (Lisp_Object obj) +{ +#ifdef SUSPICIOUS_OBJECT_CHECKING + /* Right now, we care only about vectors. */ + if (VECTORLIKEP (obj)) { + suspicious_objects[suspicious_object_index++] = XVECTOR (obj); + if (suspicious_object_index == EARRAYSIZE (suspicious_objects)) + suspicious_object_index = 0; + } +#endif + return obj; +} + #ifdef ENABLE_CHECKING bool suppress_checking; @@ -6933,6 +7037,7 @@ The time is in seconds as a floating point value. */); defsubr (&Sgarbage_collect); defsubr (&Smemory_limit); defsubr (&Smemory_use_counts); + defsubr (&Ssuspicious_object); #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES defsubr (&Sgc_status); diff --git a/src/data.c b/src/data.c index 4ef81f2..dd22098 100644 --- a/src/data.c +++ b/src/data.c @@ -727,6 +727,11 @@ DEFUN ("fset", Ffset, Sfset, 2, 2, 0, if (AUTOLOADP (function)) Fput (symbol, Qautoload, XCDR (function)); + /* Convert to eassert or remove after GC bug is found. In the + meantime, check unconditionally, at a slight perf hit. */ + if (valid_lisp_object_p (definition) < 1) + emacs_abort (); + set_symbol_function (symbol, definition); return definition; diff --git a/src/lisp.h b/src/lisp.h index 30f52b9..c501135 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -58,6 +58,9 @@ INLINE_HEADER_BEGIN #define max(a, b) ((a) > (b) ? (a) : (b)) #define min(a, b) ((a) < (b) ? (a) : (b)) +/* Find number of elements in array */ +#define EARRAYSIZE(arr) (sizeof (arr) / sizeof ((arr)[0])) + /* EMACS_INT - signed integer wide enough to hold an Emacs value EMACS_INT_MAX - maximum value of EMACS_INT; can be used in #if pI - printf length modifier for EMACS_INT -- 1.8.3.2