* src/profiler.c (Qprofiler_backtrace_equal, hashtest_profiler): New vars.
(make_log): Use them.
(handle_profiler_signal): Don't inhibit quit any longer since we don't
call Fequal any more.
(Ffunction_equal): New function.
(cmpfn_profiler, hashfn_profiler): New functions.
(syms_of_profiler): Initialize them.
* src/lisp.h (struct hash_table_test): New struct.
(struct Lisp_Hash_Table): Use it.
* src/alloc.c (mark_object): Mark hash_table_test fields of hash tables.
* src/fns.c (make_hash_table): Take a struct to describe the test.
(cmpfn_eql, cmpfn_equal, cmpfn_user_defined, hashfn_eq, hashfn_eql)
(hashfn_equal, hashfn_user_defined): Adjust to new calling convention.
(hash_lookup, hash_remove_from_table): Move assertion checking of
hashfn result here. Check hash-equality before calling cmpfn.
(Fmake_hash_table): Adjust call to make_hash_table.
(hashtest_eq, hashtest_eql, hashtest_equal): New structs.
(syms_of_fns): Initialize them.
* src/emacs.c (main): Move syms_of_fns earlier.
* src/xterm.c (syms_of_xterm):
* src/category.c (hash_get_category_set): Adjust call to make_hash_table.
* src/print.c (print_object): Adjust to new hash-table struct.
* src/composite.c (composition_gstring_put_cache): Adjust to new hashfn.
+2012-11-08 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Use ad-hoc comparison function for the profiler's hash-tables.
+ * profiler.c (Qprofiler_backtrace_equal, hashtest_profiler): New vars.
+ (make_log): Use them.
+ (handle_profiler_signal): Don't inhibit quit any longer since we don't
+ call Fequal any more.
+ (Ffunction_equal): New function.
+ (cmpfn_profiler, hashfn_profiler): New functions.
+ (syms_of_profiler): Initialize them.
+ * lisp.h (struct hash_table_test): New struct.
+ (struct Lisp_Hash_Table): Use it.
+ * alloc.c (mark_object): Mark hash_table_test fields of hash tables.
+ * fns.c (make_hash_table): Take a struct to describe the test.
+ (cmpfn_eql, cmpfn_equal, cmpfn_user_defined, hashfn_eq, hashfn_eql)
+ (hashfn_equal, hashfn_user_defined): Adjust to new calling convention.
+ (hash_lookup, hash_remove_from_table): Move assertion checking of
+ hashfn result here. Check hash-equality before calling cmpfn.
+ (Fmake_hash_table): Adjust call to make_hash_table.
+ (hashtest_eq, hashtest_eql, hashtest_equal): New structs.
+ (syms_of_fns): Initialize them.
+ * emacs.c (main): Move syms_of_fns earlier.
+ * xterm.c (syms_of_xterm):
+ * category.c (hash_get_category_set): Adjust call to make_hash_table.
+ * print.c (print_object): Adjust to new hash-table struct.
+ * composite.c (composition_gstring_put_cache): Adjust to new hashfn.
+
2012-11-08 Eli Zaretskii <eliz@gnu.org>
* w32fns.c (modifier_set): Fix handling of Scroll Lock when the
struct Lisp_Hash_Table *h = (struct Lisp_Hash_Table *) ptr;
mark_vectorlike (ptr);
+ mark_object (h->test.name);
+ mark_object (h->test.user_hash_function);
+ mark_object (h->test.user_cmp_function);
/* If hash table is not weak, mark all keys and values.
For weak tables, mark only the vector. */
if (NILP (h->weak))
if (NILP (XCHAR_TABLE (table)->extras[1]))
set_char_table_extras
(table, 1,
- make_hash_table (Qequal, make_number (DEFAULT_HASH_SIZE),
+ make_hash_table (hashtest_equal, make_number (DEFAULT_HASH_SIZE),
make_float (DEFAULT_REHASH_SIZE),
make_float (DEFAULT_REHASH_THRESHOLD),
- Qnil, Qnil, Qnil));
+ Qnil));
h = XHASH_TABLE (XCHAR_TABLE (table)->extras[1]);
i = hash_lookup (h, category_set, &hash);
if (i >= 0)
ptrdiff_t i;
header = LGSTRING_HEADER (gstring);
- hash = h->hashfn (h, header);
+ hash = h->test.hashfn (&h->test, header);
if (len < 0)
{
ptrdiff_t j, glyph_len = LGSTRING_GLYPH_LEN (gstring);
}
else
{
- /* automatic composition */
+ /* Automatic composition. */
Lisp_Object gstring = composition_gstring_from_id (cmp_it->id);
Lisp_Object glyph;
ptrdiff_t from;
/* Called before syms_of_fileio, because it sets up Qerror_condition. */
syms_of_data ();
+ syms_of_fns (); /* Before syms_of_charset which uses hashtables. */
syms_of_fileio ();
/* Before syms_of_coding to initialize Vgc_cons_threshold. */
syms_of_alloc ();
init_window_once (); /* Init the window system. */
#ifdef HAVE_WINDOW_SYSTEM
- init_fringe_once (); /* Swap bitmaps if necessary. */
+ init_fringe_once (); /* Swap bitmaps if necessary. */
#endif /* HAVE_WINDOW_SYSTEM */
}
syms_of_lread ();
syms_of_print ();
syms_of_eval ();
- syms_of_fns ();
syms_of_floatfns ();
syms_of_buffer ();
d1 = extract_float (o1);
d2 = extract_float (o2);
/* If d is a NaN, then d != d. Two NaNs should be `equal' even
- though they are not =. */
+ though they are not =. */
return d1 == d2 || (d1 != d1 && d2 != d2);
}
Low-level Functions
***********************************************************************/
+struct hash_table_test hashtest_eq, hashtest_eql, hashtest_equal;
+
/* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
HASH2 in hash table H using `eql'. Value is true if KEY1 and
KEY2 are the same. */
static bool
-cmpfn_eql (struct Lisp_Hash_Table *h,
- Lisp_Object key1, EMACS_UINT hash1,
- Lisp_Object key2, EMACS_UINT hash2)
+cmpfn_eql (struct hash_table_test *ht,
+ Lisp_Object key1,
+ Lisp_Object key2)
{
return (FLOATP (key1)
&& FLOATP (key2)
KEY2 are the same. */
static bool
-cmpfn_equal (struct Lisp_Hash_Table *h,
- Lisp_Object key1, EMACS_UINT hash1,
- Lisp_Object key2, EMACS_UINT hash2)
+cmpfn_equal (struct hash_table_test *ht,
+ Lisp_Object key1,
+ Lisp_Object key2)
{
- return hash1 == hash2 && !NILP (Fequal (key1, key2));
+ return !NILP (Fequal (key1, key2));
}
if KEY1 and KEY2 are the same. */
static bool
-cmpfn_user_defined (struct Lisp_Hash_Table *h,
- Lisp_Object key1, EMACS_UINT hash1,
- Lisp_Object key2, EMACS_UINT hash2)
+cmpfn_user_defined (struct hash_table_test *ht,
+ Lisp_Object key1,
+ Lisp_Object key2)
{
- if (hash1 == hash2)
- {
- Lisp_Object args[3];
+ Lisp_Object args[3];
- args[0] = h->user_cmp_function;
- args[1] = key1;
- args[2] = key2;
- return !NILP (Ffuncall (3, args));
- }
- else
- return 0;
+ args[0] = ht->user_cmp_function;
+ args[1] = key1;
+ args[2] = key2;
+ return !NILP (Ffuncall (3, args));
}
in a Lisp integer. */
static EMACS_UINT
-hashfn_eq (struct Lisp_Hash_Table *h, Lisp_Object key)
+hashfn_eq (struct hash_table_test *ht, Lisp_Object key)
{
EMACS_UINT hash = XUINT (key) ^ XTYPE (key);
- eassert ((hash & ~INTMASK) == 0);
return hash;
}
-
/* Value is a hash code for KEY for use in hash table H which uses
`eql' to compare keys. The hash code returned is guaranteed to fit
in a Lisp integer. */
static EMACS_UINT
-hashfn_eql (struct Lisp_Hash_Table *h, Lisp_Object key)
+hashfn_eql (struct hash_table_test *ht, Lisp_Object key)
{
EMACS_UINT hash;
if (FLOATP (key))
hash = sxhash (key, 0);
else
hash = XUINT (key) ^ XTYPE (key);
- eassert ((hash & ~INTMASK) == 0);
return hash;
}
-
/* Value is a hash code for KEY for use in hash table H which uses
`equal' to compare keys. The hash code returned is guaranteed to fit
in a Lisp integer. */
static EMACS_UINT
-hashfn_equal (struct Lisp_Hash_Table *h, Lisp_Object key)
+hashfn_equal (struct hash_table_test *ht, Lisp_Object key)
{
EMACS_UINT hash = sxhash (key, 0);
- eassert ((hash & ~INTMASK) == 0);
return hash;
}
-
/* Value is a hash code for KEY for use in hash table H which uses as
user-defined function to compare keys. The hash code returned is
guaranteed to fit in a Lisp integer. */
static EMACS_UINT
-hashfn_user_defined (struct Lisp_Hash_Table *h, Lisp_Object key)
+hashfn_user_defined (struct hash_table_test *ht, Lisp_Object key)
{
Lisp_Object args[2], hash;
- args[0] = h->user_hash_function;
+ args[0] = ht->user_hash_function;
args[1] = key;
hash = Ffuncall (2, args);
if (!INTEGERP (hash))
one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
Lisp_Object
-make_hash_table (Lisp_Object test, Lisp_Object size, Lisp_Object rehash_size,
- Lisp_Object rehash_threshold, Lisp_Object weak,
- Lisp_Object user_test, Lisp_Object user_hash)
+make_hash_table (struct hash_table_test test,
+ Lisp_Object size, Lisp_Object rehash_size,
+ Lisp_Object rehash_threshold, Lisp_Object weak)
{
struct Lisp_Hash_Table *h;
Lisp_Object table;
double index_float;
/* Preconditions. */
- eassert (SYMBOLP (test));
+ eassert (SYMBOLP (test.name));
eassert (INTEGERP (size) && XINT (size) >= 0);
eassert ((INTEGERP (rehash_size) && XINT (rehash_size) > 0)
|| (FLOATP (rehash_size) && 1 < XFLOAT_DATA (rehash_size)));
/* Initialize hash table slots. */
h->test = test;
- if (EQ (test, Qeql))
- {
- h->cmpfn = cmpfn_eql;
- h->hashfn = hashfn_eql;
- }
- else if (EQ (test, Qeq))
- {
- h->cmpfn = NULL;
- h->hashfn = hashfn_eq;
- }
- else if (EQ (test, Qequal))
- {
- h->cmpfn = cmpfn_equal;
- h->hashfn = hashfn_equal;
- }
- else
- {
- h->user_cmp_function = user_test;
- h->user_hash_function = user_hash;
- h->cmpfn = cmpfn_user_defined;
- h->hashfn = hashfn_user_defined;
- }
-
h->weak = weak;
h->rehash_threshold = rehash_threshold;
h->rehash_size = rehash_size;
ptrdiff_t start_of_bucket;
Lisp_Object idx;
- hash_code = h->hashfn (h, key);
+ hash_code = h->test.hashfn (&h->test, key);
+ eassert ((hash_code & ~INTMASK) == 0);
if (hash)
*hash = hash_code;
{
ptrdiff_t i = XFASTINT (idx);
if (EQ (key, HASH_KEY (h, i))
- || (h->cmpfn
- && h->cmpfn (h, key, hash_code,
- HASH_KEY (h, i), XUINT (HASH_HASH (h, i)))))
+ || (h->test.cmpfn
+ && hash_code == XUINT (HASH_HASH (h, i))
+ && h->test.cmpfn (&h->test, key, HASH_KEY (h, i))))
break;
idx = HASH_NEXT (h, i);
}
ptrdiff_t start_of_bucket;
Lisp_Object idx, prev;
- hash_code = h->hashfn (h, key);
+ hash_code = h->test.hashfn (&h->test, key);
+ eassert ((hash_code & ~INTMASK) == 0);
start_of_bucket = hash_code % ASIZE (h->index);
idx = HASH_INDEX (h, start_of_bucket);
prev = Qnil;
ptrdiff_t i = XFASTINT (idx);
if (EQ (key, HASH_KEY (h, i))
- || (h->cmpfn
- && h->cmpfn (h, key, hash_code,
- HASH_KEY (h, i), XUINT (HASH_HASH (h, i)))))
+ || (h->test.cmpfn
+ && hash_code == XUINT (HASH_HASH (h, i))
+ && h->test.cmpfn (&h->test, key, HASH_KEY (h, i))))
{
/* Take entry out of collision chain. */
if (NILP (prev))
(ptrdiff_t nargs, Lisp_Object *args)
{
Lisp_Object test, size, rehash_size, rehash_threshold, weak;
- Lisp_Object user_test, user_hash;
+ struct hash_table_test testdesc;
char *used;
ptrdiff_t i;
/* See if there's a `:test TEST' among the arguments. */
i = get_key_arg (QCtest, nargs, args, used);
test = i ? args[i] : Qeql;
- if (!EQ (test, Qeq) && !EQ (test, Qeql) && !EQ (test, Qequal))
+ if (EQ (test, Qeq))
+ testdesc = hashtest_eq;
+ else if (EQ (test, Qeql))
+ testdesc = hashtest_eql;
+ else if (EQ (test, Qequal))
+ testdesc = hashtest_equal;
+ else
{
/* See if it is a user-defined test. */
Lisp_Object prop;
prop = Fget (test, Qhash_table_test);
if (!CONSP (prop) || !CONSP (XCDR (prop)))
signal_error ("Invalid hash table test", test);
- user_test = XCAR (prop);
- user_hash = XCAR (XCDR (prop));
+ testdesc.name = test;
+ testdesc.user_cmp_function = XCAR (prop);
+ testdesc.user_hash_function = XCAR (XCDR (prop));
+ testdesc.hashfn = hashfn_user_defined;
+ testdesc.cmpfn = cmpfn_user_defined;
}
- else
- user_test = user_hash = Qnil;
/* See if there's a `:size SIZE' argument. */
i = get_key_arg (QCsize, nargs, args, used);
if (!used[i])
signal_error ("Invalid argument list", args[i]);
- return make_hash_table (test, size, rehash_size, rehash_threshold, weak,
- user_test, user_hash);
+ return make_hash_table (testdesc, size, rehash_size, rehash_threshold, weak);
}
doc: /* Return the test TABLE uses. */)
(Lisp_Object table)
{
- return check_hash_table (table)->test;
+ return check_hash_table (table)->test.name;
}
defsubr (&Smd5);
defsubr (&Ssecure_hash);
defsubr (&Slocale_info);
+
+ {
+ struct hash_table_test
+ eq = { Qeq, Qnil, Qnil, NULL, hashfn_eq },
+ eql = { Qeql, Qnil, Qnil, cmpfn_eql, hashfn_eql },
+ equal = { Qequal, Qnil, Qnil, cmpfn_equal, hashfn_equal };
+ hashtest_eq = eq;
+ hashtest_eql = eql;
+ hashtest_equal = equal;
+ }
}
/* The structure of a Lisp hash table. */
+struct hash_table_test
+{
+ /* Name of the function used to compare keys. */
+ Lisp_Object name;
+
+ /* User-supplied hash function, or nil. */
+ Lisp_Object user_hash_function;
+
+ /* User-supplied key comparison function, or nil. */
+ Lisp_Object user_cmp_function;
+
+ /* C function to compare two keys. */
+ bool (*cmpfn) (struct hash_table_test *t, Lisp_Object, Lisp_Object);
+
+ /* C function to compute hash code. */
+ EMACS_UINT (*hashfn) (struct hash_table_test *t, Lisp_Object);
+};
+
struct Lisp_Hash_Table
{
/* This is for Lisp; the hash table code does not refer to it. */
struct vectorlike_header header;
- /* Function used to compare keys. */
- Lisp_Object test;
-
/* Nil if table is non-weak. Otherwise a symbol describing the
weakness of the table. */
Lisp_Object weak;
hash table size to reduce collisions. */
Lisp_Object index;
- /* User-supplied hash function, or nil. */
- Lisp_Object user_hash_function;
-
- /* User-supplied key comparison function, or nil. */
- Lisp_Object user_cmp_function;
-
/* Only the fields above are traced normally by the GC. The ones below
`count' are special and are either ignored by the GC or traced in
a special way (e.g. because of weakness). */
This is gc_marked specially if the table is weak. */
Lisp_Object key_and_value;
+ /* The comparison and hash functions. */
+ struct hash_table_test test;
+
/* Next weak hash table if this is a weak hash table. The head
of the list is in weak_hash_tables. */
struct Lisp_Hash_Table *next_weak;
-
- /* C function to compare two keys. */
- bool (*cmpfn) (struct Lisp_Hash_Table *,
- Lisp_Object, EMACS_UINT,
- Lisp_Object, EMACS_UINT);
-
- /* C function to compute hash code. */
- EMACS_UINT (*hashfn) (struct Lisp_Hash_Table *, Lisp_Object);
};
extern Lisp_Object QCsize, QCtest, QCweakness, Qequal, Qeq, Qeql;
EMACS_UINT hash_string (char const *, ptrdiff_t);
EMACS_UINT sxhash (Lisp_Object, int);
-Lisp_Object make_hash_table (Lisp_Object, Lisp_Object, Lisp_Object,
- Lisp_Object, Lisp_Object, Lisp_Object,
- Lisp_Object);
+Lisp_Object make_hash_table (struct hash_table_test, Lisp_Object, Lisp_Object,
+ Lisp_Object, Lisp_Object);
ptrdiff_t hash_lookup (struct Lisp_Hash_Table *, Lisp_Object, EMACS_UINT *);
ptrdiff_t hash_put (struct Lisp_Hash_Table *, Lisp_Object, Lisp_Object,
EMACS_UINT);
+extern struct hash_table_test hashtest_eq, hashtest_eql, hashtest_equal;
extern Lisp_Object substring_both (Lisp_Object, ptrdiff_t, ptrdiff_t,
ptrdiff_t, ptrdiff_t);
#endif
/* Implement a readable output, e.g.:
#s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
- /* Always print the size. */
+ /* Always print the size. */
len = sprintf (buf, "#s(hash-table size %"pD"d", ASIZE (h->next));
strout (buf, len, len, printcharfun);
- if (!NILP (h->test))
+ if (!NILP (h->test.name))
{
strout (" test ", -1, -1, printcharfun);
- print_object (h->test, printcharfun, escapeflag);
+ print_object (h->test.name, printcharfun, escapeflag);
}
if (!NILP (h->weak))
typedef struct Lisp_Hash_Table log_t;
+static Lisp_Object Qprofiler_backtrace_equal;
+static struct hash_table_test hashtest_profiler;
+
static Lisp_Object
make_log (int heap_size, int max_stack_depth)
{
a special way. This is OK as long as the object is not exposed
to Elisp, i.e. until it is returned by *-profiler-log, after which
it can't be used any more. */
- Lisp_Object log = make_hash_table (Qequal, make_number (heap_size),
+ Lisp_Object log = make_hash_table (hashtest_profiler,
+ make_number (heap_size),
make_float (DEFAULT_REHASH_SIZE),
make_float (DEFAULT_REHASH_THRESHOLD),
- Qnil, Qnil, Qnil);
+ Qnil);
struct Lisp_Hash_Table *h = XHASH_TABLE (log);
/* What is special about our hash-tables is that the keys are pre-filled
cpu_gc_count = saturated_add (cpu_gc_count, 1);
else
{
- Lisp_Object oquit;
- bool saved_pending_signals;
EMACS_INT count = 1;
#ifdef HAVE_ITIMERSPEC
if (profiler_timer_ok)
count += overruns;
}
#endif
- /* record_backtrace uses hash functions that call Fequal, which
- uses QUIT, which can call malloc, which can cause disaster in
- a signal handler. So inhibit QUIT. */
- oquit = Vinhibit_quit;
- saved_pending_signals = pending_signals;
- Vinhibit_quit = Qt;
- pending_signals = 0;
-
eassert (HASH_TABLE_P (cpu_log));
record_backtrace (XHASH_TABLE (cpu_log), count);
-
- Vinhibit_quit = oquit;
- pending_signals = saved_pending_signals;
}
}
record_backtrace (XHASH_TABLE (memory_log), min (size, MOST_POSITIVE_FIXNUM));
}
+DEFUN ("function-equal", Ffunction_equal, Sfunction_equal, 2, 2, 0,
+ doc: /* Return non-nil if F1 and F2 come from the same source.
+Used to determine if different closures are just different instances of
+the same lambda expression, or are really unrelated function. */)
+ (Lisp_Object f1, Lisp_Object f2)
+{
+ bool res;
+ if (EQ (f1, f2))
+ res = true;
+ else if (COMPILEDP (f1) && COMPILEDP (f2))
+ res = EQ (AREF (f1, COMPILED_BYTECODE), AREF (f2, COMPILED_BYTECODE));
+ else if (CONSP (f1) && CONSP (f2) && CONSP (XCDR (f1)) && CONSP (XCDR (f2))
+ && EQ (Qclosure, XCAR (f1))
+ && EQ (Qclosure, XCAR (f2)))
+ res = EQ (XCDR (XCDR (f1)), XCDR (XCDR (f2)));
+ else
+ res = false;
+ return res ? Qt : Qnil;
+}
+
+static bool
+cmpfn_profiler (struct hash_table_test *t,
+ Lisp_Object bt1, Lisp_Object bt2)
+{
+ if (VECTORP (bt1) && VECTORP (bt2))
+ {
+ ptrdiff_t i, l = ASIZE (bt1);
+ if (l != ASIZE (bt2))
+ return false;
+ for (i = 0; i < l; i++)
+ if (NILP (Ffunction_equal (AREF (bt1, i), AREF (bt2, i))))
+ return false;
+ return true;
+ }
+ else
+ return EQ (bt1, bt2);
+}
+
+static EMACS_UINT
+hashfn_profiler (struct hash_table_test *ht, Lisp_Object bt)
+{
+ if (VECTORP (bt))
+ {
+ EMACS_UINT hash = 0;
+ ptrdiff_t i, l = ASIZE (bt);
+ for (i = 0; i < l; i++)
+ {
+ Lisp_Object f = AREF (bt, i);
+ EMACS_UINT hash1
+ = (COMPILEDP (f) ? XUINT (AREF (f, COMPILED_BYTECODE))
+ : (CONSP (f) && CONSP (XCDR (f)) && EQ (Qclosure, XCAR (f)))
+ ? XUINT (XCDR (XCDR (f))) : XUINT (f));
+ hash = hash1 + (hash << 1) + (hash == (EMACS_INT) hash);
+ }
+ return (hash & INTMASK);
+ }
+ else
+ return XUINT (bt);
+}
+
void
syms_of_profiler (void)
{
to make room for new entries. */);
profiler_log_size = 10000;
+ DEFSYM (Qprofiler_backtrace_equal, "profiler-backtrace-equal");
+ {
+ struct hash_table_test test
+ = { Qprofiler_backtrace_equal, Qnil, Qnil,
+ cmpfn_profiler, hashfn_profiler };
+ hashtest_profiler = test;
+ }
+
+ defsubr (&Sfunction_equal);
+
#ifdef PROFILER_CPU_SUPPORT
profiler_cpu_running = NOT_RUNNING;
cpu_log = Qnil;
rather than at run-time, so that re_match can be reentrant.
*/
-/* AIX requires this to be the first thing in the file. */
+/* AIX requires this to be the first thing in the file. */
#if defined _AIX && !defined REGEX_MALLOC
#pragma alloca
#endif
DEFVAR_LISP ("x-keysym-table", Vx_keysym_table,
doc: /* Hash table of character codes indexed by X keysym codes. */);
- Vx_keysym_table = make_hash_table (Qeql, make_number (900),
+ Vx_keysym_table = make_hash_table (hashtest_eql, make_number (900),
make_float (DEFAULT_REHASH_SIZE),
make_float (DEFAULT_REHASH_THRESHOLD),
- Qnil, Qnil, Qnil);
+ Qnil);
}
#endif /* HAVE_X_WINDOWS */
projects / emacs.git / commitdiff