static emacs_value
module_make_global_ref (emacs_env *env, emacs_value ref)
{
MODULE_FUNCTION_BEGIN (module_nil);
struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash);
Lisp_Object new_obj = value_to_lisp (ref);
EMACS_UINT hashcode;
ptrdiff_t i = hash_lookup (h, new_obj, &hashcode);
if (i >= 0)
{
Lisp_Object value = HASH_VALUE (h, i);
EMACS_INT refcount = XFASTINT (value) + 1;
if (MOST_POSITIVE_FIXNUM < refcount)
xsignal0 (Qoverflow_error);
value = make_natnum (refcount);
set_hash_value_slot (h, i, value);
}
else
{
hash_put (h, new_obj, make_natnum (1), hashcode);
}
return lisp_to_value (new_obj);
}
static void
module_free_global_ref (emacs_env *env, emacs_value ref)
{
/* TODO: This probably never signals. */
/* FIXME: Wait a minute. Shouldn't this function report an error if
the hash lookup fails? */
MODULE_FUNCTION_BEGIN ();
struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash);
Lisp_Object obj = value_to_lisp (ref);
EMACS_UINT hashcode;
ptrdiff_t i = hash_lookup (h, obj, &hashcode);
if (i >= 0)
{
Lisp_Object value = HASH_VALUE (h, i);
EMACS_INT refcount = XFASTINT (value) - 1;
if (refcount > 0)
{
value = make_natnum (refcount);
set_hash_value_slot (h, i, value);
}
else
hash_remove_from_table (h, value);
}
}
static void
handle_profiler_signal (int signal)
{
if (EQ (backtrace_top_function (), Qautomatic_gc))
/* Special case the time-count inside GC because the hash-table
code is not prepared to be used while the GC is running.
More specifically it uses ASIZE at many places where it does
not expect the ARRAY_MARK_FLAG to be set. We could try and
harden the hash-table code, but it doesn't seem worth the
effort. */
cpu_gc_count = saturated_add (cpu_gc_count, 1);
else
{
EMACS_INT count = 1;
#ifdef HAVE_ITIMERSPEC
if (profiler_timer_ok)
{
int overruns = timer_getoverrun (profiler_timer);
eassert (overruns >= 0);
count += overruns;
}
#endif
eassert (HASH_TABLE_P (cpu_log));
record_backtrace (XHASH_TABLE (cpu_log), count);
}
}
static Lisp_Object
hash_get_category_set (Lisp_Object table, Lisp_Object category_set)
{
struct Lisp_Hash_Table *h;
ptrdiff_t i;
EMACS_UINT hash;
if (NILP (XCHAR_TABLE (table)->extras[1]))
set_char_table_extras
(table, 1,
make_hash_table (hashtest_equal, make_number (DEFAULT_HASH_SIZE),
make_float (DEFAULT_REHASH_SIZE),
make_float (DEFAULT_REHASH_THRESHOLD),
Qnil));
h = XHASH_TABLE (XCHAR_TABLE (table)->extras[1]);
i = hash_lookup (h, category_set, &hash);
if (i >= 0)
return HASH_KEY (h, i);
hash_put (h, category_set, Qnil, hash);
return category_set;
}
static Lisp_Object
hash_get_category_set (Lisp_Object table, Lisp_Object category_set)
{
Lisp_Object val;
struct Lisp_Hash_Table *h;
int i;
unsigned hash;
if (NILP (XCHAR_TABLE (table)->extras[1]))
XCHAR_TABLE (table)->extras[1]
= make_hash_table (Qequal, make_number (DEFAULT_HASH_SIZE),
make_float (DEFAULT_REHASH_SIZE),
make_float (DEFAULT_REHASH_THRESHOLD),
Qnil, Qnil, Qnil);
h = XHASH_TABLE (XCHAR_TABLE (table)->extras[1]);
i = hash_lookup (h, category_set, &hash);
if (i >= 0)
return HASH_KEY (h, i);
hash_put (h, category_set, Qnil, hash);
return category_set;
}
static Lisp_Object
make_log (int heap_size, int max_stack_depth)
{
/* We use a standard Elisp hash-table object, but we use it in
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 (hashtest_profiler,
make_number (heap_size),
make_float (DEFAULT_REHASH_SIZE),
make_float (DEFAULT_REHASH_THRESHOLD),
Qnil);
struct Lisp_Hash_Table *h = XHASH_TABLE (log);
/* What is special about our hash-tables is that the keys are pre-filled
with the vectors we'll put in them. */
int i = ASIZE (h->key_and_value) / 2;
while (i > 0)
set_hash_key_slot (h, --i,
Fmake_vector (make_number (max_stack_depth), Qnil));
return log;
}
static json_t *
lisp_to_json_toplevel_1 (Lisp_Object lisp)
{
json_t *json;
ptrdiff_t count;
if (VECTORP (lisp))
{
ptrdiff_t size = ASIZE (lisp);
json = json_check (json_array ());
count = SPECPDL_INDEX ();
record_unwind_protect_ptr (json_release_object, json);
for (ptrdiff_t i = 0; i < size; ++i)
{
int status
= json_array_append_new (json, lisp_to_json (AREF (lisp, i)));
if (status == -1)
json_out_of_memory ();
}
eassert (json_array_size (json) == size);
}
else if (HASH_TABLE_P (lisp))
{
struct Lisp_Hash_Table *h = XHASH_TABLE (lisp);
json = json_check (json_object ());
count = SPECPDL_INDEX ();
record_unwind_protect_ptr (json_release_object, json);
for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i)
if (!NILP (HASH_HASH (h, i)))
{
Lisp_Object key = json_encode (HASH_KEY (h, i));
/* We can't specify the length, so the string must be
null-terminated. */
check_string_without_embedded_nulls (key);
const char *key_str = SSDATA (key);
/* Reject duplicate keys. These are possible if the hash
table test is not `equal'. */
if (json_object_get (json, key_str) != NULL)
wrong_type_argument (Qjson_value_p, lisp);
int status = json_object_set_new (json, key_str,
lisp_to_json (HASH_VALUE (h, i)));
if (status == -1)
{
/* A failure can be caused either by an invalid key or
by low memory. */
json_check_utf8 (key);
json_out_of_memory ();
}
}
}
else if (NILP (lisp))
return json_check (json_object ());
else if (CONSP (lisp))
{
Lisp_Object tail = lisp;
json = json_check (json_object ());
count = SPECPDL_INDEX ();
record_unwind_protect_ptr (json_release_object, json);
bool is_plist = !CONSP (XCAR (tail));
FOR_EACH_TAIL (tail)
{
const char *key_str;
Lisp_Object value;
Lisp_Object key_symbol;
if (is_plist)
{
key_symbol = XCAR (tail);
tail = XCDR (tail);
CHECK_CONS (tail);
value = XCAR (tail);
if (EQ (tail, li.tortoise)) circular_list (lisp);
}
else
{
Lisp_Object pair = XCAR (tail);
CHECK_CONS (pair);
key_symbol = XCAR (pair);
value = XCDR (pair);
}
CHECK_SYMBOL (key_symbol);
Lisp_Object key = SYMBOL_NAME (key_symbol);
/* We can't specify the length, so the string must be
null-terminated. */
check_string_without_embedded_nulls (key);
key_str = SSDATA (key);
/* In plists, ensure leading ":" in keys is stripped. It
will be reconstructed later in `json_to_lisp'.*/
if (is_plist && ':' == key_str[0] && key_str[1])
{
key_str = &key_str[1];
}
/* Only add element if key is not already present. */
if (json_object_get (json, key_str) == NULL)
{
int status
= json_object_set_new (json, key_str, lisp_to_json (value));
if (status == -1)
json_out_of_memory ();
}
}
CHECK_LIST_END (tail, lisp);
}
else
