Re: JSON/YAML/TOML/etc. parsing performance

[Philipp Stephani <p.stephani2@gmail.com>]

[-- Attachment #1.1: Type: text/plain, Size: 3903 bytes --]

Paul Eggert <eggert@cs.ucla.edu> schrieb am Di., 3. Okt. 2017 um 22:52 Uhr:

> On 10/03/2017 05:26 AM, Philipp Stephani wrote:
>
> > > +#if __has_attribute (warn_unused_result)
> > > +# define ATTRIBUTE_WARN_UNUSED_RESULT __attribute__
> > ((__warn_unused_result__))
> > > +#else
> > > +# define ATTRIBUTE_WARN_UNUSED_RESULT
> > > +#endif
> >
> > Hmm... why do we need this attribute?  You use it with 2 static
> > functions, so this sounds like a left-over from the development stage?
> >
> > It's not strictly needed (and if you don't like it, I can remove it),
> > but it helps catching memory leaks.
>
> I've found __warn_unused_result__ to be more trouble than it's worth in
> library functions. Emacs has lib/ignore-value.h in order to work around
> __warn_unused_result__ brain damage, for example. For static functions
> the problem is less, but still, I mildly favor leaving it out.
>

OK, I'll remove it.


>
> >
> >     And btw, how can size be greater than SIZE_MAX in this case? This is
> >     a valid Lisp object, isn't it?  (There are more such tests in the
> >     patch, e.g. in lisp_to_json, and I think they, too, are redundant.)
> >
> >
> > Depends on the range of ptrdiff_t and size_t. IIUC nothing in the C
> > standard guarantees PTRDIFF_MAX <= SIZE_MAX. If we want to guarantee
> > that, we should probably add at least a static assertion.
>
> There should be no need for that. No Lisp object can exceed min
> (PTRDIFF_MAX, SIZE_MAX) bytes; alloc.c guarantees this, so that Emacs
> should work even on oddball platforms where SIZE_MAX < PTRDIFF_MAX, and
> there is no need for a runtime check here.
>

Should I at least add an eassert to document this?


>
> > > +  if (buffer_and_size->size > PTRDIFF_MAX)
> > > +    xsignal1 (Qoverflow_error, build_string ("buffer too large"));
> > > +  insert (buffer_and_size->buffer, buffer_and_size->size);
> >
> > I don't think we need this test here, as 'insert' already has the
> > equivalent test in one of its subroutines.
> >
> > It can't, because it takes the byte length as ptrdiff_t. We need to
> > check before whether the size is actually in the valid range of
> ptrdiff_t.
>
> A PTRDIFF_MAX test is needed if the JSON library can return strings
> longer than PTRDIFF_MAX. Please just use buffer_overflow () to signal
> the error, though.
>

Done.


>
> > > +    case JSON_INTEGER:
> > > +      {
> > > +        json_int_t value = json_integer_value (json);
> > > +        if (FIXNUM_OVERFLOW_P (value))
> > > +          xsignal1 (Qoverflow_error,
> > > +                    build_string ("JSON integer is too large"));
> > > +        return make_number (value);
> >
> > This overflow test is also redundant, as make_number already does it.
> >
> > It can't, because json_int_t can be larger than EMACS_INT. Also,
> > make_number doesn't contain any checks.
>
> You're right that a test is needed. However, elsewhere we just use
> xsignal0 (Qoverflow_error) for this sort of thing, and I suggest being
> consistent and doing that here as well. Similarly for other calls to
> xsignal1 with Qoverflow_error.
>

Done.


>
> > > +    case JSON_STRING:
> > > +      {
> > > +        size_t size = json_string_length (json);
> > > +        if (FIXNUM_OVERFLOW_P (size))
> > > +          xsignal1 (Qoverflow_error, build_string ("JSON string is
> > too long"));
> > > +        return json_make_string (json_string_value (json), size);
> >
> > Once again, the overflow test is redundant, as make_specified_string
> > (called by json_make_string) already includes an equivalent test.
> >
> > And once again, we need to check at least whether the size fits into
> > ptrdiff_t.
> You're right, a test is needed. However, I suggest using string_overflow
> () to signal string overflows.
>
>
Done. I've attached a new patch (which currently segfaults on
decode_coding_gap, but the call to that function doesn't seem to be
required anyway).

[-- Attachment #1.2: Type: text/html, Size: 5439 bytes --]

[-- Attachment #2: 0001-Implement-native-JSON-support-using-Jansson.txt --]
[-- Type: text/plain, Size: 31728 bytes --]

From 16919f7ffda7fb057d4c4486f92396dab636e5b8 Mon Sep 17 00:00:00 2001
From: Philipp Stephani <phst@google.com>
Date: Mon, 18 Sep 2017 10:51:39 +0200
Subject: [PATCH] Implement native JSON support using Jansson

* configure.ac: New option --with-json.

* src/json.c (Fjson_serialize, Fjson_insert, Fjson_parse_string)
(Fjson_parse_buffer): New defuns.
(json_has_prefix, json_has_suffix, json_make_string)
(json_build_string, json_encode, json_out_of_memory, json_parse_error)
(json_release_object, check_string_without_embedded_nulls, json_check)
(lisp_to_json, lisp_to_json_toplevel, lisp_to_json_toplevel_1)
(json_insert, json_insert_callback, json_to_lisp)
(json_read_buffer_callback, Fjson_parse_buffer, define_error): New
helper functions.
(syms_of_json): New file.

* src/lisp.h: Declaration for syms_of_json.

* src/conf_post.h (ATTRIBUTE_WARN_UNUSED_RESULT): New attribute macro.

* src/emacs.c (main): Enable JSON functions.

* src/eval.c (internal_catch_all, internal_catch_all_1): New helper
functions to catch all signals.
(syms_of_eval): Add uninterned symbol to signify out of memory.

* src/Makefile.in (JSON_LIBS, JSON_CFLAGS, JSON_OBJ, EMACS_CFLAGS)
(base_obj, LIBES): Compile json.c if --with-json is enabled.

* test/src/json-tests.el (json-serialize/roundtrip)
(json-serialize/object, json-parse-string/object)
(json-parse-string/string, json-serialize/string)
(json-parse-string/incomplete, json-parse-string/trailing)
(json-parse-buffer/incomplete, json-parse-buffer/trailing): New unit
tests.
---
 configure.ac           |  20 +-
 etc/NEWS               |   7 +
 src/Makefile.in        |  11 +-
 src/conf_post.h        |   6 +
 src/emacs.c            |   4 +
 src/eval.c             |  54 +++++
 src/json.c             | 542 +++++++++++++++++++++++++++++++++++++++++++++++++
 src/lisp.h             |   6 +
 test/src/json-tests.el |  97 +++++++++
 9 files changed, 743 insertions(+), 4 deletions(-)
 create mode 100644 src/json.c
 create mode 100644 test/src/json-tests.el

diff --git a/configure.ac b/configure.ac
index 627a392a5b..7d191a32cd 100644
--- a/configure.ac
+++ b/configure.ac
@@ -355,6 +355,7 @@ AC_DEFUN
 OPTION_DEFAULT_OFF([cairo],[compile with Cairo drawing (experimental)])
 OPTION_DEFAULT_ON([xml2],[don't compile with XML parsing support])
 OPTION_DEFAULT_ON([imagemagick],[don't compile with ImageMagick image support])
+OPTION_DEFAULT_ON([json], [don't compile with native JSON support])
 
 OPTION_DEFAULT_ON([xft],[don't use XFT for anti aliased fonts])
 OPTION_DEFAULT_ON([libotf],[don't use libotf for OpenType font support])
@@ -2859,6 +2860,22 @@ AC_DEFUN
 AC_SUBST(LIBSYSTEMD_LIBS)
 AC_SUBST(LIBSYSTEMD_CFLAGS)
 
+HAVE_JSON=no
+JSON_OBJ=
+
+if test "${with_json}" = yes; then
+  EMACS_CHECK_MODULES([JSON], [jansson >= 2.5],
+    [HAVE_JSON=yes], [HAVE_JSON=no])
+  if test "${HAVE_JSON}" = yes; then
+    AC_DEFINE(HAVE_JSON, 1, [Define if using Jansson.])
+    JSON_OBJ=json.o
+  fi
+fi
+
+AC_SUBST(JSON_LIBS)
+AC_SUBST(JSON_CFLAGS)
+AC_SUBST(JSON_OBJ)
+
 NOTIFY_OBJ=
 NOTIFY_SUMMARY=no
 
@@ -5370,7 +5387,7 @@ AC_DEFUN
 for opt in XAW3D XPM JPEG TIFF GIF PNG RSVG CAIRO IMAGEMAGICK SOUND GPM DBUS \
   GCONF GSETTINGS NOTIFY ACL LIBSELINUX GNUTLS LIBXML2 FREETYPE M17N_FLT \
   LIBOTF XFT ZLIB TOOLKIT_SCROLL_BARS X_TOOLKIT OLDXMENU X11 NS MODULES \
-  XWIDGETS LIBSYSTEMD CANNOT_DUMP LCMS2; do
+  XWIDGETS LIBSYSTEMD JSON CANNOT_DUMP LCMS2; do
 
     case $opt in
       CANNOT_DUMP) eval val=\${$opt} ;;
@@ -5420,6 +5437,7 @@ AC_DEFUN
   Does Emacs use -lotf?                                   ${HAVE_LIBOTF}
   Does Emacs use -lxft?                                   ${HAVE_XFT}
   Does Emacs use -lsystemd?                               ${HAVE_LIBSYSTEMD}
+  Does Emacs use -ljansson?                               ${HAVE_JSON}
   Does Emacs directly use zlib?                           ${HAVE_ZLIB}
   Does Emacs have dynamic modules support?                ${HAVE_MODULES}
   Does Emacs use toolkit scroll bars?                     ${USE_TOOLKIT_SCROLL_BARS}
diff --git a/etc/NEWS b/etc/NEWS
index 75a98d1500..4a9976828b 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -25,6 +25,13 @@ When you add a new item, use the appropriate mark if you are sure it applies,
 \f
 * Installation Changes in Emacs 27.1
 
+** The new configure option '--with-json' adds support for JSON using
+the Jansson library.  It is on by default; use 'configure
+--with-json=no' to build without Jansson support.  The new JSON
+functions 'json-serialize', 'json-insert', 'json-parse-string', and
+'json-parse-buffer' are typically much faster than their Lisp
+counterparts from json.el.
+
 \f
 * Startup Changes in Emacs 27.1
 
diff --git a/src/Makefile.in b/src/Makefile.in
index 9a8c9c85f0..b395627893 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -312,6 +312,10 @@ LIBGNUTLS_CFLAGS =
 LIBSYSTEMD_LIBS = @LIBSYSTEMD_LIBS@
 LIBSYSTEMD_CFLAGS = @LIBSYSTEMD_CFLAGS@
 
+JSON_LIBS = @JSON_LIBS@
+JSON_CFLAGS = @JSON_CFLAGS@
+JSON_OBJ = @JSON_OBJ@
+
 INTERVALS_H = dispextern.h intervals.h composite.h
 
 GETLOADAVG_LIBS = @GETLOADAVG_LIBS@
@@ -363,7 +367,7 @@ EMACS_CFLAGS=
   $(WEBKIT_CFLAGS) \
   $(SETTINGS_CFLAGS) $(FREETYPE_CFLAGS) $(FONTCONFIG_CFLAGS) \
   $(LIBOTF_CFLAGS) $(M17N_FLT_CFLAGS) $(DEPFLAGS) \
-  $(LIBSYSTEMD_CFLAGS) \
+  $(LIBSYSTEMD_CFLAGS) $(JSON_CFLAGS) \
   $(LIBGNUTLS_CFLAGS) $(NOTIFY_CFLAGS) $(CAIRO_CFLAGS) \
   $(WERROR_CFLAGS)
 ALL_CFLAGS = $(EMACS_CFLAGS) $(WARN_CFLAGS) $(CFLAGS)
@@ -397,7 +401,7 @@ base_obj =
 	thread.o systhread.o \
 	$(if $(HYBRID_MALLOC),sheap.o) \
 	$(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) \
-	$(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ)
+	$(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ) $(JSON_OBJ)
 obj = $(base_obj) $(NS_OBJC_OBJ)
 
 ## Object files used on some machine or other.
@@ -493,7 +497,8 @@ LIBES =
    $(LIBS_TERMCAP) $(GETLOADAVG_LIBS) $(SETTINGS_LIBS) $(LIBSELINUX_LIBS) \
    $(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \
    $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) $(LIBLCMS2) \
-   $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS)
+   $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) \
+   $(JSON_LIBS)
 
 ## FORCE it so that admin/unidata can decide whether these files
 ## are up-to-date.  Although since charprop depends on bootstrap-emacs,
diff --git a/src/conf_post.h b/src/conf_post.h
index febdb8b8bf..1a7f51fa51 100644
--- a/src/conf_post.h
+++ b/src/conf_post.h
@@ -338,6 +338,12 @@ extern int emacs_setenv_TZ (char const *);
 # define ATTRIBUTE_NO_SANITIZE_ADDRESS
 #endif
 
+#if __has_attribute (warn_unused_result)
+# define ATTRIBUTE_WARN_UNUSED_RESULT __attribute__ ((__warn_unused_result__))
+#else
+# define ATTRIBUTE_WARN_UNUSED_RESULT
+#endif
+
 /* gcc -fsanitize=address does not work with vfork in Fedora 25 x86-64.
    For now, assume that this problem occurs on all platforms.  */
 #if ADDRESS_SANITIZER && !defined vfork
diff --git a/src/emacs.c b/src/emacs.c
index 0fe7d9113b..39761016ef 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -1610,6 +1610,10 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
       syms_of_threads ();
       syms_of_profiler ();
 
+#ifdef HAVE_JSON
+      syms_of_json ();
+#endif
+
       keys_of_casefiddle ();
       keys_of_cmds ();
       keys_of_buffer ();
diff --git a/src/eval.c b/src/eval.c
index acda64e7f0..11804d1819 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -1416,6 +1416,57 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *),
     }
 }
 
+static Lisp_Object
+internal_catch_all_1 (Lisp_Object (*function) (void *), void *argument)
+{
+  struct handler *c = push_handler_nosignal (Qt, CATCHER_ALL);
+  if (c == NULL)
+    return Qcatch_all_memory_full;
+
+  if (sys_setjmp (c->jmp) == 0)
+    {
+      Lisp_Object val = function (argument);
+      eassert (handlerlist == c);
+      handlerlist = c->next;
+      return val;
+    }
+  else
+    {
+      eassert (handlerlist == c);
+      Lisp_Object val = c->val;
+      handlerlist = c->next;
+      Fsignal (Qno_catch, val);
+    }
+}
+
+/* Like a combination of internal_condition_case_1 and internal_catch.
+   Catches all signals and throws.  Never exits nonlocally; returns
+   Qcatch_all_memory_full if no handler could be allocated.  */
+
+Lisp_Object
+internal_catch_all (Lisp_Object (*function) (void *), void *argument,
+                    Lisp_Object (*handler) (Lisp_Object))
+{
+  struct handler *c = push_handler_nosignal (Qt, CONDITION_CASE);
+  if (c == NULL)
+    return Qcatch_all_memory_full;
+
+  if (sys_setjmp (c->jmp) == 0)
+    {
+      Lisp_Object val = internal_catch_all_1 (function, argument);
+      eassert (handlerlist == c);
+      handlerlist = c->next;
+      return val;
+    }
+  else
+    {
+      eassert (handlerlist == c);
+      Lisp_Object val = c->val;
+      handlerlist = c->next;
+      return handler (val);
+    }
+}
+
 struct handler *
 push_handler (Lisp_Object tag_ch_val, enum handlertype handlertype)
 {
@@ -4065,6 +4116,9 @@ alist of active lexical bindings.  */);
 
   inhibit_lisp_code = Qnil;
 
+  DEFSYM (Qcatch_all_memory_full, "catch-all-memory-full");
+  Funintern (Qcatch_all_memory_full, Qnil);
+
   defsubr (&Sor);
   defsubr (&Sand);
   defsubr (&Sif);
diff --git a/src/json.c b/src/json.c
new file mode 100644
index 0000000000..f704479dd7
--- /dev/null
+++ b/src/json.c
@@ -0,0 +1,542 @@
+/* JSON parsing and serialization.
+
+Copyright (C) 2017 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs 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.
+
+GNU Emacs 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 GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.  */
+
+#include <config.h>
+
+#include <stddef.h>
+#include <stdint.h>
+
+#include <jansson.h>
+
+#include "lisp.h"
+#include "buffer.h"
+#include "coding.h"
+
+static bool
+json_has_prefix (const char *string, const char *prefix)
+{
+  size_t string_len = strlen (string);
+  size_t prefix_len = strlen (prefix);
+  return string_len >= prefix_len && memcmp (string, prefix, prefix_len) == 0;
+}
+
+static bool
+json_has_suffix (const char *string, const char *suffix)
+{
+  size_t string_len = strlen (string);
+  size_t suffix_len = strlen (suffix);
+  return string_len >= suffix_len
+    && memcmp (string + string_len - suffix_len, suffix, suffix_len) == 0;
+}
+
+static Lisp_Object
+json_make_string (const char *data, ptrdiff_t size)
+{
+  return make_specified_string (data, -1, size, true);
+}
+
+static Lisp_Object
+json_build_string (const char *data)
+{
+  size_t size = strlen (data);
+  if (FIXNUM_OVERFLOW_P (size))
+    string_overflow ();
+  return json_make_string (data, size);
+}
+
+static Lisp_Object
+json_encode (Lisp_Object string)
+{
+  return code_convert_string (string, Qutf_8_unix, Qt, true, true, true);
+}
+
+static _Noreturn void
+json_out_of_memory (void)
+{
+  xsignal0 (Qjson_out_of_memory);
+}
+
+static _Noreturn void
+json_parse_error (const json_error_t *error)
+{
+  Lisp_Object symbol;
+  /* FIXME: Upstream Jansson should have a way to return error codes
+     without parsing the error messages.  See
+     https://github.com/akheron/jansson/issues/352.  */
+  if (json_has_suffix (error->text, "expected near end of file"))
+    symbol = Qjson_end_of_file;
+  else if (json_has_prefix (error->text, "end of file expected"))
+    symbol = Qjson_trailing_content;
+  else
+    symbol = Qjson_parse_error;
+  xsignal (symbol,
+           list5 (json_build_string (error->text),
+                  json_build_string (error->source), make_natnum (error->line),
+                  make_natnum (error->column), make_natnum (error->position)));
+}
+
+static void
+json_release_object (void *object)
+{
+  json_decref (object);
+}
+
+static void
+check_string_without_embedded_nulls (Lisp_Object object)
+{
+  CHECK_STRING (object);
+  CHECK_TYPE (memchr (SDATA (object), '\0', SBYTES (object)) == NULL,
+              Qstring_without_embedded_nulls_p, object);
+}
+
+static json_t *
+json_check (json_t *object)
+{
+  if (object == NULL)
+    json_out_of_memory ();
+  return object;
+}
+
+static json_t *lisp_to_json (Lisp_Object);
+
+/* This returns Lisp_Object so we can use unbind_to.  The return value
+   is always nil.  */
+
+static _GL_ARG_NONNULL ((2)) Lisp_Object
+lisp_to_json_toplevel_1 (Lisp_Object lisp, json_t **json)
+{
+  if (VECTORP (lisp))
+    {
+      ptrdiff_t size = ASIZE (lisp);
+      eassert (size >= 0);
+      eassert (size <= SIZE_MAX);
+      *json = json_check (json_array ());
+      ptrdiff_t 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 (status == 0);
+        }
+      eassert (json_array_size (*json) == size);
+      clear_unwind_protect (count);
+      return unbind_to (count, Qnil);
+    }
+  else if (HASH_TABLE_P (lisp))
+    {
+      struct Lisp_Hash_Table *h = XHASH_TABLE (lisp);
+      *json = json_check (json_object ());
+      ptrdiff_t 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);
+            int status = json_object_set_new (*json, SSDATA (key),
+                                              lisp_to_json (HASH_VALUE (h, i)));
+            if (status == -1)
+              json_out_of_memory ();
+            eassert (status == 0);
+          }
+      clear_unwind_protect (count);
+      return unbind_to (count, Qnil);
+    }
+  wrong_type_argument (Qjson_value_p, lisp);
+}
+
+static json_t *
+lisp_to_json_toplevel (Lisp_Object lisp)
+{
+  if (++lisp_eval_depth > max_lisp_eval_depth)
+    xsignal0 (Qjson_object_too_deep);
+  json_t *json;
+  lisp_to_json_toplevel_1 (lisp, &json);
+  --lisp_eval_depth;
+  return json;
+}
+
+static json_t *
+lisp_to_json (Lisp_Object lisp)
+{
+  if (EQ (lisp, QCnull))
+    return json_check (json_null ());
+  else if (EQ (lisp, QCfalse))
+    return json_check (json_false ());
+  else if (EQ (lisp, Qt))
+    return json_check (json_true ());
+  else if (INTEGERP (lisp))
+    {
+      CHECK_TYPE_RANGED_INTEGER (json_int_t, lisp);
+      return json_check (json_integer (XINT (lisp)));
+    }
+  else if (FLOATP (lisp))
+    return json_check (json_real (XFLOAT_DATA (lisp)));
+  else if (STRINGP (lisp))
+    {
+      Lisp_Object encoded = json_encode (lisp);
+      ptrdiff_t size = SBYTES (encoded);
+      eassert (size >= 0);
+      eassert (size <= SIZE_MAX);
+      return json_check (json_stringn (SSDATA (encoded), size));
+    }
+
+  /* LISP now must be a vector or hashtable.  */
+  return lisp_to_json_toplevel (lisp);
+}
+
+DEFUN ("json-serialize", Fjson_serialize, Sjson_serialize, 1, 1, NULL,
+       doc: /* Return the JSON representation of OBJECT as a string.
+OBJECT must be a vector or hashtable, and its elements can recursively
+contain `:null', `:false', t, numbers, strings, or other vectors and
+hashtables.  `:null', `:false', and t will be converted to JSON null,
+false, and true values, respectively.  Vectors will be converted to
+JSON arrays, and hashtables to JSON objects.  Hashtable keys must be
+strings without embedded null characters and must be unique within
+each object.  */)
+  (Lisp_Object object)
+{
+  ptrdiff_t count = SPECPDL_INDEX ();
+
+  json_t *json = lisp_to_json_toplevel (object);
+  record_unwind_protect_ptr (json_release_object, json);
+
+  char *string = json_dumps (json, JSON_COMPACT);
+  if (string == NULL)
+    json_out_of_memory ();
+  record_unwind_protect_ptr (free, string);
+
+  return unbind_to (count, json_build_string (string));
+}
+
+struct json_buffer_and_size
+{
+  const char *buffer;
+  size_t nbytes;
+  ptrdiff_t nchars;
+};
+
+static Lisp_Object
+json_insert (void *data)
+{
+  struct json_buffer_and_size *buffer_and_size = data;
+  size_t nbytes = buffer_and_size->nbytes;
+  if (nbytes == 0)
+    return Qnil;
+  if (nbytes > PTRDIFF_MAX)
+    buffer_overflow ();
+  const char *buffer = buffer_and_size->buffer;
+  ptrdiff_t nchars
+    = chars_in_text ((const unsigned char *) buffer_and_size->buffer, nbytes);
+  insert_1_both (buffer, nchars, nbytes, false, false, false);
+  buffer_and_size->nchars = nchars;
+  return Qnil;
+}
+
+struct json_insert_data
+{
+  /* nil if json_insert succeeded, otherwise the symbol
+     Qcatch_all_memory_full or a cons (ERROR-SYMBOL . ERROR-DATA).  */
+  Lisp_Object error;
+  ptrdiff_t nchars;
+  ptrdiff_t nbytes;
+};
+
+static int
+json_insert_callback (const char *buffer, size_t size, void *data)
+{
+  /* This function may not exit nonlocally.  */
+  struct json_insert_data *d = data;
+  struct json_buffer_and_size buffer_and_size
+    = {.buffer = buffer, .nbytes = size, .nchars = 0};
+  d->error = internal_catch_all (json_insert, &buffer_and_size, Fidentity);
+  bool overflow = INT_ADD_WRAPV (d->nchars, buffer_and_size.nchars, &d->nchars);
+  eassert (!overflow);
+  overflow = INT_ADD_WRAPV (d->nbytes, size, &d->nbytes);
+  eassert (!overflow);
+  return NILP (d->error) ? 0 : -1;
+}
+
+DEFUN ("json-insert", Fjson_insert, Sjson_insert, 1, 1, NULL,
+       doc: /* Insert the JSON representation of OBJECT before point.
+This is the same as (insert (json-serialize OBJECT)), but potentially
+faster.  See the function `json-serialize' for allowed values of
+OBJECT.  */)
+  (Lisp_Object object)
+{
+  ptrdiff_t count = SPECPDL_INDEX ();
+
+  json_t *json = lisp_to_json (object);
+  record_unwind_protect_ptr (json_release_object, json);
+
+  ptrdiff_t opoint = PT;
+  prepare_to_modify_buffer (opoint, opoint, NULL);
+
+  struct json_insert_data data;
+  int status
+    = json_dump_callback (json, json_insert_callback, &data, JSON_COMPACT);
+  if (status == -1)
+    {
+      if (CONSP (data.error))
+        xsignal (XCAR (data.error), XCDR (data.error));
+      else
+        json_out_of_memory ();
+    }
+  eassert (status == 0);
+  eassert (NILP (data.error));
+
+  struct coding_system coding;
+  setup_coding_system (Qutf_8_unix, &coding);
+  eassert (PT == GPT);
+  decode_coding_gap (&coding, data.nchars, data.nbytes);
+
+  signal_after_change (opoint, 0, data.nchars);
+  update_compositions (opoint, PT, CHECK_BORDER);
+  return unbind_to (count, Qnil);
+}
+
+static _GL_ARG_NONNULL ((1)) Lisp_Object
+json_to_lisp (json_t *json)
+{
+  switch (json_typeof (json))
+    {
+    case JSON_NULL:
+      return QCnull;
+    case JSON_FALSE:
+      return QCfalse;
+    case JSON_TRUE:
+      return Qt;
+    case JSON_INTEGER:
+      {
+        json_int_t value = json_integer_value (json);
+        if (FIXNUM_OVERFLOW_P (value))
+          xsignal0 (Qoverflow_error);
+        return make_number (value);
+      }
+    case JSON_REAL:
+      return make_float (json_real_value (json));
+    case JSON_STRING:
+      {
+        size_t size = json_string_length (json);
+        if (FIXNUM_OVERFLOW_P (size))
+          string_overflow ();
+        return json_make_string (json_string_value (json), size);
+      }
+    case JSON_ARRAY:
+      {
+        if (++lisp_eval_depth > max_lisp_eval_depth)
+          xsignal0 (Qjson_object_too_deep);
+        size_t size = json_array_size (json);
+        if (FIXNUM_OVERFLOW_P (size))
+          xsignal0 (Qoverflow_error);
+        Lisp_Object result = Fmake_vector (make_natnum (size), Qunbound);
+        for (ptrdiff_t i = 0; i < size; ++i)
+          ASET (result, i,
+                json_to_lisp (json_array_get (json, i)));
+        --lisp_eval_depth;
+        return result;
+      }
+    case JSON_OBJECT:
+      {
+        if (++lisp_eval_depth > max_lisp_eval_depth)
+          xsignal0 (Qjson_object_too_deep);
+        size_t size = json_object_size (json);
+        if (FIXNUM_OVERFLOW_P (size))
+          xsignal0 (Qoverflow_error);
+        Lisp_Object result = CALLN (Fmake_hash_table, QCtest, Qequal,
+                                    QCsize, make_natnum (size));
+        struct Lisp_Hash_Table *h = XHASH_TABLE (result);
+        const char *key_str;
+        json_t *value;
+        json_object_foreach (json, key_str, value)
+          {
+            Lisp_Object key = json_build_string (key_str);
+            EMACS_UINT hash;
+            ptrdiff_t i = hash_lookup (h, key, &hash);
+            eassert (i < 0);
+            hash_put (h, key, json_to_lisp (value), hash);
+          }
+        --lisp_eval_depth;
+        return result;
+      }
+    }
+  /* Can’t get here.  */
+  emacs_abort ();
+}
+
+DEFUN ("json-parse-string", Fjson_parse_string, Sjson_parse_string, 1, 1, NULL,
+       doc: /* Parse the JSON STRING into a Lisp object.
+This is essentially the reverse operation of `json-serialize', which
+see.  The returned object will be a vector or hashtable.  Its elements
+will be `:null', `:false', t, numbers, strings, or further vectors and
+hashtables.  If there are duplicate keys in an object, all but the
+last one are ignored.  If STRING doesn't contain a valid JSON object,
+an error of type `json-parse-error' is signaled.  */)
+  (Lisp_Object string)
+{
+  ptrdiff_t count = SPECPDL_INDEX ();
+  Lisp_Object encoded = json_encode (string);
+  check_string_without_embedded_nulls (encoded);
+
+  json_error_t error;
+  json_t *object = json_loads (SSDATA (encoded), 0, &error);
+  if (object == NULL)
+    json_parse_error (&error);
+
+  /* Avoid leaking the object in case of further errors.  */
+  if (object != NULL)
+    record_unwind_protect_ptr (json_release_object, object);
+
+  return unbind_to (count, json_to_lisp (object));
+}
+
+struct json_read_buffer_data
+{
+  ptrdiff_t point;
+};
+
+static size_t
+json_read_buffer_callback (void *buffer, size_t buflen, void *data)
+{
+  struct json_read_buffer_data *d = data;
+
+  /* First, parse from point to the gap or the end of the accessible
+     portion, whatever is closer.  */
+  ptrdiff_t point = d->point;
+  ptrdiff_t end;
+  {
+    bool overflow = INT_ADD_WRAPV (BUFFER_CEILING_OF (point), 1, &end);
+    eassert (!overflow);
+  }
+  size_t count;
+  {
+    bool overflow = INT_SUBTRACT_WRAPV (end, point, &count);
+    eassert (!overflow);
+  }
+  if (buflen < count)
+    count = buflen;
+  memcpy (buffer, BYTE_POS_ADDR (point), count);
+  {
+    bool overflow = INT_ADD_WRAPV (d->point, count, &d->point);
+    eassert (!overflow);
+  }
+  return count;
+}
+
+DEFUN ("json-parse-buffer", Fjson_parse_buffer, Sjson_parse_buffer,
+       0, 0, NULL,
+       doc: /* Read JSON object from current buffer starting at point.
+This is similar to `json-parse-string', which see.  Move point after
+the end of the object if parsing was successful.  On error, point is
+not moved.  */)
+  (void)
+{
+  ptrdiff_t count = SPECPDL_INDEX ();
+
+  ptrdiff_t point = PT_BYTE;
+  struct json_read_buffer_data data = {.point = point};
+  json_error_t error;
+  json_t *object = json_load_callback (json_read_buffer_callback, &data,
+                                       JSON_DISABLE_EOF_CHECK, &error);
+
+  if (object == NULL)
+    json_parse_error (&error);
+
+  /* Avoid leaking the object in case of further errors.  */
+  record_unwind_protect_ptr (json_release_object, object);
+
+  /* Convert and then move point only if everything succeeded.  */
+  Lisp_Object lisp = json_to_lisp (object);
+
+  {
+    /* Adjust point by how much we just read.  Do this here because
+       tokener->char_offset becomes incorrect below.  */
+    bool overflow = INT_ADD_WRAPV (point, error.position, &point);
+    eassert (!overflow);
+    eassert (point <= ZV_BYTE);
+    SET_PT_BOTH (BYTE_TO_CHAR (point), point);
+  }
+
+  return unbind_to (count, lisp);
+}
+
+/* Simplified version of ‘define-error’ that works with pure
+   objects.  */
+
+static void
+define_error (Lisp_Object name, const char *message, Lisp_Object parent)
+{
+  eassert (SYMBOLP (name));
+  eassert (SYMBOLP (parent));
+  Lisp_Object parent_conditions = Fget (parent, Qerror_conditions);
+  eassert (CONSP (parent_conditions));
+  eassert (!NILP (Fmemq (parent, parent_conditions)));
+  eassert (NILP (Fmemq (name, parent_conditions)));
+  Fput (name, Qerror_conditions, pure_cons (name, parent_conditions));
+  Fput (name, Qerror_message, build_pure_c_string (message));
+}
+
+void
+syms_of_json (void)
+{
+  DEFSYM (QCnull, ":null");
+  DEFSYM (QCfalse, ":false");
+
+  DEFSYM (Qstring_without_embedded_nulls_p, "string-without-embedded-nulls-p");
+  DEFSYM (Qjson_value_p, "json-value-p");
+
+  DEFSYM (Qutf_8_unix, "utf-8-unix");
+
+  DEFSYM (Qjson_error, "json-error");
+  DEFSYM (Qjson_out_of_memory, "json-out-of-memory");
+  DEFSYM (Qjson_parse_error, "json-parse-error");
+  DEFSYM (Qjson_end_of_file, "json-end-of-file");
+  DEFSYM (Qjson_trailing_content, "json-trailing-content");
+  DEFSYM (Qjson_object_too_deep, "json-object-too-deep");
+  define_error (Qjson_error, "generic JSON error", Qerror);
+  define_error (Qjson_out_of_memory,
+                "not enough memory for creating JSON object", Qjson_error);
+  define_error (Qjson_parse_error, "could not parse JSON stream",
+                Qjson_error);
+  define_error (Qjson_end_of_file, "end of JSON stream", Qjson_parse_error);
+  define_error (Qjson_trailing_content, "trailing content after JSON stream",
+                Qjson_parse_error);
+  define_error (Qjson_object_too_deep,
+                "object cyclic or Lisp evaluation too deep", Qjson_error);
+
+  DEFSYM (Qpure, "pure");
+  DEFSYM (Qside_effect_free, "side-effect-free");
+
+  DEFSYM (Qjson_serialize, "json-serialize");
+  DEFSYM (Qjson_parse_string, "json-parse-string");
+  Fput (Qjson_serialize, Qpure, Qt);
+  Fput (Qjson_serialize, Qside_effect_free, Qt);
+  Fput (Qjson_parse_string, Qpure, Qt);
+  Fput (Qjson_parse_string, Qside_effect_free, Qt);
+
+  defsubr (&Sjson_serialize);
+  defsubr (&Sjson_insert);
+  defsubr (&Sjson_parse_string);
+  defsubr (&Sjson_parse_buffer);
+}
diff --git a/src/lisp.h b/src/lisp.h
index 266370333f..3ab8fdc4f3 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -3441,6 +3441,11 @@ extern int x_bitmap_mask (struct frame *, ptrdiff_t);
 extern void reset_image_types (void);
 extern void syms_of_image (void);
 
+#ifdef HAVE_JSON
+/* Defined in json.c.  */
+extern void syms_of_json (void);
+#endif
+
 /* Defined in insdel.c.  */
 extern void move_gap_both (ptrdiff_t, ptrdiff_t);
 extern _Noreturn void buffer_overflow (void);
@@ -3864,6 +3869,7 @@ extern Lisp_Object internal_condition_case_2 (Lisp_Object (*) (Lisp_Object, Lisp
 extern Lisp_Object internal_condition_case_n
     (Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *,
      Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *));
+extern Lisp_Object internal_catch_all (Lisp_Object (*) (void *), void *, Lisp_Object (*) (Lisp_Object));
 extern struct handler *push_handler (Lisp_Object, enum handlertype);
 extern struct handler *push_handler_nosignal (Lisp_Object, enum handlertype);
 extern void specbind (Lisp_Object, Lisp_Object);
diff --git a/test/src/json-tests.el b/test/src/json-tests.el
new file mode 100644
index 0000000000..5d3c84a136
--- /dev/null
+++ b/test/src/json-tests.el
@@ -0,0 +1,97 @@
+;;; json-tests.el --- unit tests for json.c          -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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.
+
+;; GNU Emacs 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 GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Unit tests for src/json.c.
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'map)
+
+(ert-deftest json-serialize/roundtrip ()
+  (let ((lisp [:null :false t 0 123 -456 3.75 "abcαβγ"])
+        (json "[null,false,true,0,123,-456,3.75,\"abcαβγ\"]"))
+    (should (equal (json-serialize lisp) json))
+    (with-temp-buffer
+      (json-insert lisp)
+      (should (equal (buffer-string) json))
+      (should (eobp)))
+    (should (equal (json-parse-string json) lisp))
+    (with-temp-buffer
+      (insert json)
+      (goto-char 1)
+      (should (equal (json-parse-buffer) lisp))
+      (should (eobp)))))
+
+(ert-deftest json-serialize/object ()
+  (let ((table (make-hash-table :test #'equal)))
+    (puthash "abc" [1 2 t] table)
+    (puthash "def" :null table)
+    (should (equal (json-serialize table)
+                   "{\"abc\":[1,2,true],\"def\":null}"))))
+
+(ert-deftest json-parse-string/object ()
+  (let ((actual
+         (json-parse-string
+          "{ \"abc\" : [1, 2, true], \"def\" : null, \"abc\" : [9, false] }\n")))
+    (should (hash-table-p actual))
+    (should (equal (hash-table-count actual) 2))
+    (should (equal (cl-sort (map-pairs actual) #'string< :key #'car)
+                   '(("abc" . [9 :false]) ("def" . :null))))))
+
+(ert-deftest json-parse-string/string ()
+  (should-error (json-parse-string "[\"formfeed\f\"]") :type 'json-parse-error)
+  (should (equal (json-parse-string "[\"foo \\\"bar\\\"\"]") ["foo \"bar\""]))
+  (should (equal (json-parse-string "[\"abcαβγ\"]") ["abcαβγ"]))
+  (should (equal (json-parse-string "[\"\\nasd\\u0444\\u044b\\u0432fgh\\t\"]")
+                 ["\nasdфывfgh\t"]))
+  (should (equal (json-parse-string "[\"\\uD834\\uDD1E\"]") ["\U0001D11E"]))
+  (should-error (json-parse-string "foo") :type 'json-parse-error))
+
+(ert-deftest json-serialize/string ()
+  (should (equal (json-serialize ["foo"]) "[\"foo\"]"))
+  (should (equal (json-serialize ["a\n\fb"]) "[\"a\\n\\fb\"]"))
+  (should (equal (json-serialize ["\nasdфыв\u001f\u007ffgh\t"])
+                 "[\"\\nasdфыв\\u001F\u007ffgh\\t\"]")))
+
+(ert-deftest json-parse-string/incomplete ()
+  (should-error (json-parse-string "[123") :type 'json-end-of-file))
+
+(ert-deftest json-parse-string/trailing ()
+  (should-error (json-parse-string "[123] [456]") :type 'json-trailing-content))
+
+(ert-deftest json-parse-buffer/incomplete ()
+  (with-temp-buffer
+    (insert "[123")
+    (goto-char 1)
+    (should-error (json-parse-buffer) :type 'json-end-of-file)
+    (should (bobp))))
+
+(ert-deftest json-parse-buffer/trailing ()
+  (with-temp-buffer
+    (insert "[123] [456]")
+    (goto-char 1)
+    (should (equal (json-parse-buffer) [123]))
+    (should-not (bobp))
+    (should (looking-at-p (rx " [456]" eos)))))
+
+(provide 'json-tests)
+;;; json-tests.el ends here
-- 
2.14.2