;; 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))
-;; Comment out the fset if you want to debug the GC bug.
+ (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)))
#include <verify.h>
+#ifdef HAVE_EXECINFO_H
+#include <execinfo.h> /* For backtrace */
+#endif
+
#if (defined ENABLE_CHECKING \
&& defined HAVE_VALGRIND_VALGRIND_H \
&& !defined USE_VALGRIND)
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
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))
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;
}
Vmemory_full = Qnil;
#endif
}
+
\f
/************************************************************************
C Stack Marking
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;
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);
projects / emacs.git / commitdiff