[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] feature/libjit a166e8f 4/4: JIT compiler
|
From: |
Tom Tromey |
|
Subject: |
[Emacs-diffs] feature/libjit a166e8f 4/4: JIT compiler |
|
Date: |
Mon, 13 Aug 2018 20:16:59 -0400 (EDT) |
branch: feature/libjit
commit a166e8fabda6fbc7a49d2da2c9ae99efc2e3c23e
Author: Tom Tromey <address@hidden>
Commit: Tom Tromey <address@hidden>
JIT compiler
* lisp/emacs-lisp/jit-support.el: New file.
* src/alloc.c (make_byte_code): Remove.
(Fmake_byte_code): Rewrite.
* src/data.c (Fsubr_arity, notify_variable_watchers): Update.
* src/emacs.c (main): Call syms_of_jit, init_jit.
* src/eval.c (eval_sub, Fapply, FUNCTIONP, Ffuncall, funcall_subr)
(funcall_lambda): Update.
* src/jit.c: New file.
* src/lisp.h (struct subr_function): New struct, extracted from
Lisp_Subr.
(SUBR_MAX_ARGS): New define.
(struct Lisp_Subr): Use struct subr_function.
(COMPILED_JIT_CODE): New constant.
(DEFUN): Update.
(make_byte_code): Don't declare.
(funcall_subr): Add error_obj argument.
(syms_of_jit, init_jit, emacs_jit_compile): Declare.
* src/lread.c (read1): Use Fmake_byte_code.
* test/src/jit-tests.el: New file.
---
lisp/emacs-lisp/jit-support.el | 37 +
src/alloc.c | 43 +-
src/data.c | 7 +-
src/emacs.c | 8 +
src/eval.c | 92 +-
src/jit.c | 2367 ++++++++++++++++++++++++++++++++++++++++
src/lisp.h | 37 +-
src/lread.c | 3 +-
test/src/jit-tests.el | 304 ++++++
9 files changed, 2825 insertions(+), 73 deletions(-)
diff --git a/lisp/emacs-lisp/jit-support.el b/lisp/emacs-lisp/jit-support.el
new file mode 100644
index 0000000..b318f3b
--- /dev/null
+++ b/lisp/emacs-lisp/jit-support.el
@@ -0,0 +1,37 @@
+;;; jit-support.el --- helper functions for JIT compilation -*-
lexical-binding: t -*-
+
+;; Copyright (C) 2018 Free Software Foundation, Inc.
+
+;; Keywords: lisp
+;; Package: emacs
+
+;; 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/>.
+
+;;;###autoload
+(defun jit-disassemble (func)
+ (interactive "aDisassemble function: ")
+ (when (symbolp func)
+ (setf func (symbol-function func)))
+ (let ((str (jit-disassemble-to-string func)))
+ (with-current-buffer (get-buffer-create "*JIT*")
+ (erase-buffer)
+ (save-excursion
+ (insert str))
+ (pop-to-buffer (current-buffer)))))
+
+(provide 'jit-support)
+
+;;; jit-support.el ends here
diff --git a/src/alloc.c b/src/alloc.c
index 337668f..ca70c0c 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -3515,23 +3515,6 @@ usage: (vector &rest OBJECTS) */)
return val;
}
-void
-make_byte_code (struct Lisp_Vector *v)
-{
- /* Don't allow the global zero_vector to become a byte code object. */
- eassert (0 < v->header.size);
-
- if (v->header.size > 1 && STRINGP (v->contents[1])
- && STRING_MULTIBYTE (v->contents[1]))
- /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
- earlier because they produced a raw 8-bit string for byte-code
- and now such a byte-code string is loaded as multibyte while
- raw 8-bit characters converted to multibyte form. Thus, now we
- must convert them back to the original unibyte form. */
- v->contents[1] = Fstring_as_unibyte (v->contents[1]);
- XSETPVECTYPE (v, PVEC_COMPILED);
-}
-
DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0,
doc: /* Create a byte-code object with specified arguments as elements.
The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
@@ -3550,8 +3533,14 @@ stack before executing the byte-code.
usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING
INTERACTIVE-SPEC &rest ELEMENTS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- Lisp_Object val = make_uninit_vector (nargs);
- struct Lisp_Vector *p = XVECTOR (val);
+ Lisp_Object val;
+ struct Lisp_Vector *p = allocate_pseudovector (COMPILED_JIT_CODE + 1,
+ COMPILED_JIT_CODE,
+ COMPILED_JIT_CODE + 1,
+ PVEC_COMPILED);
+
+ /* Don't allow the global zero_vector to become a byte code object. */
+ eassert (0 < nargs);
/* We used to purecopy everything here, if purify-flag was set. This worked
OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
@@ -3562,7 +3551,21 @@ usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH
&optional DOCSTRING INT
to be setcar'd). */
memcpy (p->contents, args, nargs * sizeof *args);
- make_byte_code (p);
+ for (int i = nargs; i < COMPILED_JIT_CODE; ++i)
+ p->contents[i] = Qnil;
+
+ /* Not really a Lisp_Object. */
+ p->contents[COMPILED_JIT_CODE] = (Lisp_Object) NULL;
+
+ if (STRINGP (p->contents[COMPILED_BYTECODE])
+ && STRING_MULTIBYTE (p->contents[COMPILED_BYTECODE]))
+ /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
+ earlier because they produced a raw 8-bit string for byte-code
+ and now such a byte-code string is loaded as multibyte while
+ raw 8-bit characters converted to multibyte form. Thus, now we
+ must convert them back to the original unibyte form. */
+ p->contents[COMPILED_BYTECODE] = Fstring_as_unibyte
(p->contents[COMPILED_BYTECODE]);
+
XSETCOMPILED (val, p);
return val;
}
diff --git a/src/data.c b/src/data.c
index a1215b9..7a0659d 100644
--- a/src/data.c
+++ b/src/data.c
@@ -866,8 +866,8 @@ function with `&rest' args, or `unevalled' for a special
form. */)
{
short minargs, maxargs;
CHECK_SUBR (subr);
- minargs = XSUBR (subr)->min_args;
- maxargs = XSUBR (subr)->max_args;
+ minargs = XSUBR (subr)->function.min_args;
+ maxargs = XSUBR (subr)->function.max_args;
return Fcons (make_fixnum (minargs),
maxargs == MANY ? Qmany
: maxargs == UNEVALLED ? Qunevalled
@@ -1571,7 +1571,8 @@ notify_variable_watchers (Lisp_Object symbol,
if (SUBRP (watcher))
{
Lisp_Object args[] = { symbol, newval, operation, where };
- funcall_subr (XSUBR (watcher), ARRAYELTS (args), args);
+ funcall_subr (watcher, &XSUBR (watcher)->function,
+ ARRAYELTS (args), args);
}
else
CALLN (Ffuncall, watcher, symbol, newval, operation, where);
diff --git a/src/emacs.c b/src/emacs.c
index 97205d2..25493c2 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -1643,6 +1643,10 @@ Using an Emacs configured with --with-x-toolkit=lucid
does not have this problem
syms_of_json ();
#endif
+#ifdef HAVE_LIBJIT
+ syms_of_jit ();
+#endif
+
keys_of_casefiddle ();
keys_of_cmds ();
keys_of_buffer ();
@@ -1663,6 +1667,10 @@ Using an Emacs configured with --with-x-toolkit=lucid
does not have this problem
#if defined WINDOWSNT || defined HAVE_NTGUI
globals_of_w32select ();
#endif
+
+#ifdef HAVE_LIBJIT
+ init_jit ();
+#endif
}
init_charset ();
diff --git a/src/eval.c b/src/eval.c
index 8745ba9..de87f9b 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -30,6 +30,10 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "dispextern.h"
#include "buffer.h"
+#ifdef HAVE_LIBJIT
+#include <jit/jit.h>
+#endif
+
/* CACHEABLE is ordinarily nothing, except it is 'volatile' if
necessary to cajole GCC into not warning incorrectly that a
variable should be volatile. */
@@ -2230,14 +2234,14 @@ eval_sub (Lisp_Object form)
check_cons_list ();
- if (XFIXNUM (numargs) < XSUBR (fun)->min_args
- || (XSUBR (fun)->max_args >= 0
- && XSUBR (fun)->max_args < XFIXNUM (numargs)))
+ if (XFIXNUM (numargs) < XSUBR (fun)->function.min_args
+ || (XSUBR (fun)->function.max_args >= 0
+ && XSUBR (fun)->function.max_args < XFIXNUM (numargs)))
xsignal2 (Qwrong_number_of_arguments, original_fun, numargs);
- else if (XSUBR (fun)->max_args == UNEVALLED)
- val = (XSUBR (fun)->function.aUNEVALLED) (args_left);
- else if (XSUBR (fun)->max_args == MANY)
+ else if (XSUBR (fun)->function.max_args == UNEVALLED)
+ val = (XSUBR (fun)->function.function.aUNEVALLED) (args_left);
+ else if (XSUBR (fun)->function.max_args == MANY)
{
/* Pass a vector of evaluated arguments. */
Lisp_Object *vals;
@@ -2255,7 +2259,7 @@ eval_sub (Lisp_Object form)
set_backtrace_args (specpdl + count, vals, argnum);
- val = XSUBR (fun)->function.aMANY (argnum, vals);
+ val = XSUBR (fun)->function.function.aMANY (argnum, vals);
check_cons_list ();
lisp_eval_depth--;
@@ -2268,7 +2272,7 @@ eval_sub (Lisp_Object form)
}
else
{
- int i, maxargs = XSUBR (fun)->max_args;
+ int i, maxargs = XSUBR (fun)->function.max_args;
for (i = 0; i < maxargs; i++)
{
@@ -2281,40 +2285,40 @@ eval_sub (Lisp_Object form)
switch (i)
{
case 0:
- val = (XSUBR (fun)->function.a0 ());
+ val = (XSUBR (fun)->function.function.a0 ());
break;
case 1:
- val = (XSUBR (fun)->function.a1 (argvals[0]));
+ val = (XSUBR (fun)->function.function.a1 (argvals[0]));
break;
case 2:
- val = (XSUBR (fun)->function.a2 (argvals[0], argvals[1]));
+ val = (XSUBR (fun)->function.function.a2 (argvals[0],
argvals[1]));
break;
case 3:
- val = (XSUBR (fun)->function.a3
+ val = (XSUBR (fun)->function.function.a3
(argvals[0], argvals[1], argvals[2]));
break;
case 4:
- val = (XSUBR (fun)->function.a4
+ val = (XSUBR (fun)->function.function.a4
(argvals[0], argvals[1], argvals[2], argvals[3]));
break;
case 5:
- val = (XSUBR (fun)->function.a5
+ val = (XSUBR (fun)->function.function.a5
(argvals[0], argvals[1], argvals[2], argvals[3],
argvals[4]));
break;
case 6:
- val = (XSUBR (fun)->function.a6
+ val = (XSUBR (fun)->function.function.a6
(argvals[0], argvals[1], argvals[2], argvals[3],
argvals[4], argvals[5]));
break;
case 7:
- val = (XSUBR (fun)->function.a7
+ val = (XSUBR (fun)->function.function.a7
(argvals[0], argvals[1], argvals[2], argvals[3],
argvals[4], argvals[5], argvals[6]));
break;
case 8:
- val = (XSUBR (fun)->function.a8
+ val = (XSUBR (fun)->function.function.a8
(argvals[0], argvals[1], argvals[2], argvals[3],
argvals[4], argvals[5], argvals[6], argvals[7]));
break;
@@ -2411,16 +2415,16 @@ usage: (apply FUNCTION &rest ARGUMENTS) */)
fun = args[0];
}
- if (SUBRP (fun) && XSUBR (fun)->max_args > numargs
+ if (SUBRP (fun) && XSUBR (fun)->function.max_args > numargs
/* Don't hide an error by adding missing arguments. */
- && numargs >= XSUBR (fun)->min_args)
+ && numargs >= XSUBR (fun)->function.min_args)
{
/* Avoid making funcall cons up a yet another new vector of arguments
by explicitly supplying nil's for optional values. */
- SAFE_ALLOCA_LISP (funcall_args, 1 + XSUBR (fun)->max_args);
+ SAFE_ALLOCA_LISP (funcall_args, 1 + XSUBR (fun)->function.max_args);
memclear (funcall_args + numargs + 1,
- (XSUBR (fun)->max_args - numargs) * word_size);
- funcall_nargs = 1 + XSUBR (fun)->max_args;
+ (XSUBR (fun)->function.max_args - numargs) * word_size);
+ funcall_nargs = 1 + XSUBR (fun)->function.max_args;
}
else
{ /* We add 1 to numargs because funcall_args includes the
@@ -2764,7 +2768,7 @@ FUNCTIONP (Lisp_Object object)
}
if (SUBRP (object))
- return XSUBR (object)->max_args != UNEVALLED;
+ return XSUBR (object)->function.max_args != UNEVALLED;
else if (COMPILEDP (object) || MODULE_FUNCTIONP (object))
return true;
else if (CONSP (object))
@@ -2819,7 +2823,12 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
fun = indirect_function (fun);
if (SUBRP (fun))
- val = funcall_subr (XSUBR (fun), numargs, args + 1);
+ val = funcall_subr (fun, &XSUBR (fun)->function, numargs, args + 1);
+ else if (COMPILEDP (fun)
+ && XVECTOR (fun)->contents[COMPILED_JIT_CODE] != NULL)
+ val = funcall_subr (fun,
+ (struct subr_function *) XVECTOR
(fun)->contents[COMPILED_JIT_CODE],
+ numargs, args + 1);
else if (COMPILEDP (fun) || MODULE_FUNCTIONP (fun))
val = funcall_lambda (fun, numargs, args + 1);
else
@@ -2856,28 +2865,19 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
and return the result of evaluation. */
Lisp_Object
-funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, Lisp_Object *args)
+funcall_subr (Lisp_Object error_obj, struct subr_function *subr,
+ ptrdiff_t numargs, Lisp_Object *args)
{
if (numargs < subr->min_args
|| (subr->max_args >= 0 && subr->max_args < numargs))
- {
- Lisp_Object fun;
- XSETSUBR (fun, subr);
- xsignal2 (Qwrong_number_of_arguments, fun, make_fixnum (numargs));
- }
-
+ xsignal2 (Qwrong_number_of_arguments, error_obj, make_fixnum (numargs));
else if (subr->max_args == UNEVALLED)
- {
- Lisp_Object fun;
- XSETSUBR (fun, subr);
- xsignal1 (Qinvalid_function, fun);
- }
-
+ xsignal1 (Qinvalid_function, error_obj);
else if (subr->max_args == MANY)
return (subr->function.aMANY) (numargs, args);
else
{
- Lisp_Object internal_argbuf[8];
+ Lisp_Object internal_argbuf[SUBR_MAX_ARGS];
Lisp_Object *internal_args;
if (subr->max_args > numargs)
{
@@ -3020,6 +3020,22 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
and constants vector yet, fetch them from the file. */
if (CONSP (AREF (fun, COMPILED_BYTECODE)))
Ffetch_bytecode (fun);
+
+#ifdef HAVE_LIBJIT
+ if (initialized)
+ {
+ struct Lisp_Vector *vec = XVECTOR (fun);
+
+ if (vec->contents[COMPILED_JIT_CODE] == NULL)
+ emacs_jit_compile (fun);
+
+ if (vec->contents[COMPILED_JIT_CODE] != NULL)
+ return funcall_subr (fun,
+ (struct subr_function *)
vec->contents[COMPILED_JIT_CODE],
+ nargs, arg_vector);
+ }
+#endif /* HAVE_LIBJIT */
+
return exec_byte_code (AREF (fun, COMPILED_BYTECODE),
AREF (fun, COMPILED_CONSTANTS),
AREF (fun, COMPILED_STACK_DEPTH),
diff --git a/src/jit.c b/src/jit.c
new file mode 100644
index 0000000..94a83d2
--- /dev/null
+++ b/src/jit.c
@@ -0,0 +1,2367 @@
+/* Execution of byte code produced by bytecomp.el.
+ Copyright (C) 2018 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>
+
+#ifdef HAVE_LIBJIT
+
+#include "lisp.h"
+#include "buffer.h"
+#include "bytecode.h"
+#include "window.h"
+
+#include <stdio.h>
+#include <jit/jit.h>
+#include <jit/jit-dump.h>
+
+static bool emacs_jit_initialized;
+
+jit_context_t emacs_jit_context;
+
+static jit_type_t nullary_signature;
+static jit_type_t unary_signature;
+static jit_type_t binary_signature;
+static jit_type_t ternary_signature;
+static jit_type_t unbind_n_signature;
+static jit_type_t temp_output_buffer_show_signature;
+static jit_type_t arithcompare_signature;
+static jit_type_t callN_signature;
+static jit_type_t compiled_signature;
+static jit_type_t wrong_number_of_arguments_signature;
+static jit_type_t set_internal_signature;
+static jit_type_t specbind_signature;
+static jit_type_t record_unwind_protect_excursion_signature;
+static jit_type_t record_unwind_protect_signature;
+static jit_type_t void_void_signature;
+static jit_type_t push_handler_signature;
+static jit_type_t setjmp_signature;
+
+static jit_type_t subr_signature[SUBR_MAX_ARGS];
+
+static jit_type_t ptrdiff_t_type;
+
+
+/* Make a pointer constant. */
+#define CONSTANT(FUNC, VAL) \
+ jit_value_create_long_constant (FUNC, jit_type_void_ptr, (jit_long) (VAL))
+
+/* Fetch the next byte from the bytecode stream. */
+
+#define FETCH (bytestr_data[pc++])
+
+/* Fetch two bytes from the bytecode stream and make a 16-bit number
+ out of them. */
+
+#define FETCH2 (op = FETCH, op + (FETCH << 8))
+
+#define PUSH(VALUE) \
+ jit_insn_store (func, stack[++stack_pointer], VALUE)
+
+#define POP stack[stack_pointer--]
+
+/* Discard n values from the execution stack. */
+
+#define DISCARD(n) (stack_pointer -= (n))
+
+/* Get the value which is at the top of the execution stack, but don't
+ pop it. */
+
+#define TOP stack[stack_pointer]
+
+/* Compile code that extracts the type from VAL. */
+
+static jit_value_t
+get_type (jit_function_t func, jit_value_t val)
+{
+#if USE_LSB_TAG
+ jit_value_t mask = jit_value_create_nint_constant (func, jit_type_void_ptr,
+ ~VALMASK);
+ return jit_insn_and (func, val, mask);
+#else /* USE_LSB_TAG */
+ jit_value_t shift = jit_value_create_nint_constant (func, jit_type_uint,
+ VALBITS);
+ return jit_insn_ushr (func, val, shift);
+#endif /* not USE_LSB_TAG */
+}
+
+static jit_value_t
+untag (jit_function_t func, jit_value_t val, EMACS_UINT utype)
+{
+ jit_value_t tem;
+
+ utype = utype << (USE_LSB_TAG ? 0 : VALBITS);
+
+ tem = jit_value_create_nint_constant (func, jit_type_void_ptr, utype);
+ return jit_insn_sub (func, val, tem);
+}
+
+static jit_value_t
+to_int (jit_function_t func, jit_value_t val)
+{
+ jit_value_t shift = jit_value_create_nint_constant (func, jit_type_uint,
+ INTTYPEBITS);
+#if !USE_LSB_TAG
+ val = jit_insn_shl (func, val, shift);
+#endif
+ return jit_insn_sshr (func, val, shift);
+}
+
+static jit_value_t
+eq_nil (jit_function_t func, jit_value_t val)
+{
+ jit_value_t nilval = CONSTANT (func, Qnil);
+ return jit_insn_eq (func, val, nilval);
+}
+
+static jit_value_t
+compare_type (jit_function_t func, jit_value_t val, int to_be_checked)
+{
+ jit_value_t real_type = get_type (func, val);
+ jit_value_t type_val
+ = jit_value_create_nint_constant (func, jit_type_void_ptr, to_be_checked);
+ return jit_insn_eq (func, real_type, type_val);
+}
+
+/* If the next instruction in the stream is a conditional branch,
+ return true and compile jumps based on COMPARE. Otherwise, return
+ false. */
+
+static bool
+peek_condition (jit_function_t func,
+ unsigned char *bytestr_data, ptrdiff_t pc,
+ jit_value_t compare, jit_value_t dest,
+ jit_label_t *labels)
+{
+ int op = FETCH;
+
+ switch (op)
+ {
+ case Bgotoifnil:
+ op = FETCH2;
+ jit_insn_branch_if_not (func, compare, &labels[op]);
+ break;
+
+ case Bgotoifnonnil:
+ op = FETCH2;
+ jit_insn_branch_if (func, compare, &labels[op]);
+ break;
+
+ case Bgotoifnilelsepop:
+ op = FETCH2;
+ jit_insn_store (func, dest, CONSTANT (func, Qnil));
+ jit_insn_branch_if_not (func, compare, &labels[op]);
+ break;
+
+ case Bgotoifnonnilelsepop:
+ op = FETCH2;
+ jit_insn_store (func, dest, CONSTANT (func, Qt));
+ jit_insn_branch_if (func, compare, &labels[op]);
+ break;
+
+ case BRgotoifnil:
+ op = FETCH - 128;
+ op += pc;
+ jit_insn_branch_if_not (func, compare, &labels[op]);
+ break;
+
+ case BRgotoifnonnil:
+ op = FETCH - 128;
+ op += pc;
+ jit_insn_branch_if (func, compare, &labels[op]);
+ break;
+
+ case BRgotoifnilelsepop:
+ op = FETCH - 128;
+ op += pc;
+ jit_insn_store (func, dest, CONSTANT (func, Qnil));
+ jit_insn_branch_if_not (func, compare, &labels[op]);
+ break;
+
+ case BRgotoifnonnilelsepop:
+ op = FETCH - 128;
+ op += pc;
+ jit_insn_store (func, dest, CONSTANT (func, Qt));
+ jit_insn_branch_if (func, compare, &labels[op]);
+ break;
+
+ default:
+ return false;
+ }
+
+ /* This is necessary to bypass the (probably dead) code that will be
+ emitted for the branch in the main JIT loop. */
+ jit_insn_branch (func, &labels[pc]);
+
+ return true;
+}
+
+static void
+emit_qnil_or_qt (jit_function_t func,
+ unsigned char *bytestr_data, ptrdiff_t pc,
+ jit_value_t compare, jit_value_t dest,
+ jit_label_t *labels)
+{
+ jit_value_t tem;
+
+ /* Optimize the case where we see bytecode like:
+ Beq
+ Bgotoifnil [...]
+ Here, we don't actually need to load and store the `nil' or `t'
+ -- we can just branch directly based on the condition we just
+ computed. */
+ if (!peek_condition (func, bytestr_data, pc, compare, dest, labels))
+ {
+ /* Actually must emit a load of Qt or Qnil. */
+ jit_label_t nil_label = jit_label_undefined;
+ jit_insn_branch_if_not (func, compare, &nil_label);
+ tem = CONSTANT (func, Qt);
+ jit_insn_store (func, dest, tem);
+ jit_insn_branch (func, &labels[pc]);
+ jit_insn_label (func, &nil_label);
+ tem = CONSTANT (func, Qnil);
+ jit_insn_store (func, dest, tem);
+ }
+}
+
+static jit_value_t
+compile_nullary (jit_function_t func, const char *name,
+ Lisp_Object (*callee) (void))
+{
+ return jit_insn_call_native (func, name, (void *) callee,
+ nullary_signature, NULL, 0,
+ JIT_CALL_NOTHROW);
+}
+
+static void
+
+compile_unary (jit_function_t func, const char *name,
+ Lisp_Object (*callee) (Lisp_Object),
+ jit_value_t arg_and_dest)
+{
+ jit_value_t result = jit_insn_call_native (func, name, (void *) callee,
+ unary_signature, &arg_and_dest, 1,
+ JIT_CALL_NOTHROW);
+ jit_insn_store (func, arg_and_dest, result);
+}
+
+static void
+compile_binary (jit_function_t func, const char *name,
+ Lisp_Object (*callee) (Lisp_Object, Lisp_Object),
+ jit_value_t arg_and_dest, jit_value_t arg2)
+{
+ jit_value_t args[2] = { arg_and_dest, arg2 };
+
+ jit_value_t result = jit_insn_call_native (func, name, (void *) callee,
+ binary_signature, args, 2,
+ JIT_CALL_NOTHROW);
+ jit_insn_store (func, arg_and_dest, result);
+}
+
+static void
+compile_ternary (jit_function_t func, const char *name,
+ Lisp_Object (*callee) (Lisp_Object, Lisp_Object, Lisp_Object),
+ jit_value_t arg_and_dest, jit_value_t arg2, jit_value_t arg3)
+{
+ jit_value_t args[3] = { arg_and_dest, arg2, arg3 };
+
+ jit_value_t result = jit_insn_call_native (func, name, (void *) callee,
+ ternary_signature, args, 3,
+ JIT_CALL_NOTHROW);
+ jit_insn_store (func, arg_and_dest, result);
+}
+
+static void
+compile_arithcompare (jit_function_t func, const char *name,
+ jit_value_t arg_and_dest, jit_value_t arg2, int arg3)
+{
+ jit_value_t tem
+ = jit_value_create_nint_constant (func, jit_type_sys_int, arg3);
+ jit_value_t args[3] = { arg_and_dest, arg2, tem };
+
+ jit_value_t result = jit_insn_call_native (func, name, (void *) arithcompare,
+ arithcompare_signature, args, 3,
+ JIT_CALL_NOTHROW);
+ jit_insn_store (func, arg_and_dest, result);
+}
+
+static jit_value_t
+compile_make_natnum (jit_function_t func, jit_value_t untagged_int)
+{
+#if USE_LSB_TAG
+ jit_value_t nbits
+ = jit_value_create_nint_constant (func, jit_type_int, INTTYPEBITS);
+ jit_value_t val = jit_insn_shl (func, untagged_int, nbits);
+ jit_value_t tag
+ = jit_value_create_nint_constant (func, jit_type_void_ptr, Lisp_Int0);
+ return jit_insn_add (func, val, tag);
+#else /* USE_LSB_TAG */
+ jit_value_t tag
+ = jit_value_create_nint_constant (func, jit_type_void_ptr,
+ ((EMACS_INT) Lisp_Int0) << VALBITS);
+ return jit_insn_add (func, untagged_int, tag);
+#endif /* not USE_LSB_TAG */
+}
+
+static jit_value_t
+compile_make_number (jit_function_t func, jit_value_t untagged_int)
+{
+#if USE_LSB_TAG
+ jit_value_t nbits
+ = jit_value_create_nint_constant (func, jit_type_int, INTTYPEBITS);
+ jit_value_t val = jit_insn_shl (func, untagged_int, nbits);
+ jit_value_t tag
+ = jit_value_create_nint_constant (func, jit_type_void_ptr, Lisp_Int0);
+ return jit_insn_add (func, val, tag);
+#else /* USE_LSB_TAG */
+ jit_value_t mask
+ = jit_value_create_nint_constant (func, jit_type_void_ptr, INTMASK);
+ jit_value_t tag
+ = jit_value_create_nint_constant (func, jit_type_void_ptr,
+ ((EMACS_INT) Lisp_Int0) << VALBITS);
+ jit_value_t val = jit_insn_and (func, untagged_int, mask);
+ return jit_insn_add (func, val, tag);
+#endif /* not USE_LSB_TAG */
+}
+
+static jit_value_t
+compile_current_thread (jit_function_t func)
+{
+ jit_value_t thread_ptr = CONSTANT (func, ¤t_thread);
+ return jit_insn_load_relative (func, thread_ptr, 0, jit_type_void_ptr);
+}
+
+static jit_value_t
+compile_current_buffer (jit_function_t func)
+{
+ jit_value_t current_thread = compile_current_thread (func);
+ return jit_insn_load_relative (func, current_thread,
+ offsetof (struct thread_state,
+ m_current_buffer),
+ jit_type_void_ptr);
+}
+
+static jit_value_t
+compile_buffer_int (jit_function_t func, off_t offset)
+{
+ jit_value_t current_buffer_val = compile_current_buffer (func);
+ jit_value_t value
+ = jit_insn_load_relative (func, current_buffer_val, offset,
+ ptrdiff_t_type);
+
+ return compile_make_natnum (func, value);
+}
+
+static jit_value_t
+compare_buffer_ints (jit_function_t func, off_t off1, off_t off2)
+{
+ jit_value_t current_buffer_val = compile_current_buffer (func);
+ jit_value_t value1
+ = jit_insn_load_relative (func, current_buffer_val, off1,
+ ptrdiff_t_type);
+ jit_value_t value2
+ = jit_insn_load_relative (func, current_buffer_val, off2,
+ ptrdiff_t_type);
+ return jit_insn_eq (func, value1, value2);
+}
+
+static void
+car_or_cdr (jit_function_t func, jit_value_t val, off_t offset,
+ jit_label_t *next_insn, bool safe,
+ bool *called_wtype, jit_label_t *wtype_label,
+ jit_value_t wtype_arg)
+{
+ jit_value_t tem;
+ jit_label_t not_a_cons = jit_label_undefined;
+
+ jit_value_t is_cons = compare_type (func, val, Lisp_Cons);
+ jit_insn_branch_if_not (func, is_cons, ¬_a_cons);
+
+ /* Is a cons. */
+ tem = untag (func, val, Lisp_Cons);
+ tem = jit_insn_load_relative (func, tem, offset,
+ jit_type_void_ptr);
+ jit_insn_store (func, val, tem);
+ jit_insn_branch (func, next_insn);
+
+ jit_insn_label (func, ¬_a_cons);
+ if (safe)
+ {
+ /* Not a cons, so just use nil. */
+ jit_value_t nilval = CONSTANT (func, Qnil);
+ jit_insn_store (func, val, nilval);
+ }
+ else
+ {
+ /* Check if it is nil. */
+ tem = eq_nil (func, val);
+ /* If it is nil, VAL is already correct and we can carry on. */
+ jit_insn_branch_if (func, tem, next_insn);
+
+ /* Wrong type. */
+ jit_insn_store (func, wtype_arg, val);
+ jit_insn_branch (func, wtype_label);
+ *called_wtype = true;
+ }
+}
+
+static void
+compile_wrong_type_argument (jit_function_t func, jit_label_t *label,
+ jit_value_t wtype_arg)
+{
+ jit_value_t args[2];
+
+ args[0] = CONSTANT (func, Qlistp);
+ args[1] = wtype_arg;
+
+ jit_insn_label (func, label);
+ jit_insn_call_native (func, "wrong_type_argument",
+ (void *) wrong_type_argument,
+ /* FIXME incorrect signature. */
+ binary_signature, args, 2,
+ JIT_CALL_NORETURN);
+}
+
+static jit_value_t
+compare_integerp (jit_function_t func, jit_value_t val, jit_value_t *type_out)
+{
+ jit_value_t type = get_type (func, val);
+ if (type_out != NULL)
+ *type_out = type;
+
+ jit_value_t c1
+ = jit_value_create_nint_constant (func, jit_type_void_ptr,
+ Lisp_Int0 | ~Lisp_Int1);
+ jit_value_t c2
+ = jit_value_create_nint_constant (func, jit_type_void_ptr,
+ Lisp_Int0);
+ jit_value_t tem = jit_insn_and (func, type, c1);
+
+ return jit_insn_eq (func, tem, c2);
+}
+
+static Lisp_Object
+negate (Lisp_Object arg)
+{
+ return Fminus (1, &arg);
+}
+
+enum math_op
+{
+ SUB1,
+ ADD1,
+ NEGATE
+};
+
+static void
+unary_intmath (jit_function_t func, jit_value_t val, enum math_op op,
+ jit_label_t *next_insn)
+{
+ jit_label_t not_an_int = jit_label_undefined;
+ jit_value_t compare = compare_integerp (func, val, NULL);
+
+ jit_insn_branch_if_not (func, compare, ¬_an_int);
+
+ /* Got an integer. */
+ jit_value_t result = to_int (func, val);
+ jit_value_t tem;
+ switch (op)
+ {
+ case SUB1:
+ /* Don't allow (1- most-negative-fixnum). */
+ tem = jit_value_create_nint_constant (func, jit_type_sys_int,
+ MOST_NEGATIVE_FIXNUM);
+ compare = jit_insn_eq (func, result, tem);
+ jit_insn_branch_if (func, compare, ¬_an_int);
+
+ tem = jit_value_create_nint_constant (func, jit_type_sys_int, 1);
+ result = jit_insn_sub (func, result, tem);
+ break;
+
+ case ADD1:
+ /* Don't allow (1+ most-positive-fixnum). */
+ tem = jit_value_create_nint_constant (func, jit_type_sys_int,
+ MOST_POSITIVE_FIXNUM);
+ compare = jit_insn_eq (func, result, tem);
+ jit_insn_branch_if (func, compare, ¬_an_int);
+
+ tem = jit_value_create_nint_constant (func, jit_type_sys_int, 1);
+ result = jit_insn_add (func, result, tem);
+ break;
+
+ case NEGATE:
+ /* Don't allow (- most-negative-fixnum). */
+ tem = jit_value_create_nint_constant (func, jit_type_sys_int,
+ MOST_NEGATIVE_FIXNUM);
+ compare = jit_insn_eq (func, result, tem);
+ jit_insn_branch_if (func, compare, ¬_an_int);
+
+ result = jit_insn_neg (func, result);
+ break;
+
+ default:
+ emacs_abort ();
+ }
+
+ result = compile_make_number (func, result);
+ jit_insn_store (func, val, result);
+ jit_insn_branch (func, next_insn);
+
+ jit_insn_label (func, ¬_an_int);
+
+ const char *name;
+ void *callee;
+ switch (op)
+ {
+ case SUB1:
+ name = "Fsub1";
+ callee = (void *) Fsub1;
+ break;
+ case ADD1:
+ name = "Fadd1";
+ callee = (void *) Fadd1;
+ break;
+ case NEGATE:
+ name = "negate";
+ callee = (void *) negate;
+ break;
+ default:
+ emacs_abort ();
+ }
+
+ tem = jit_insn_call_native (func, name, (void *) callee,
+ unary_signature, &val, 1,
+ JIT_CALL_NOTHROW);
+ jit_insn_store (func, val, tem);
+}
+
+static jit_value_t
+compile_callN (jit_function_t func, const char *name,
+ Lisp_Object (*callee) (ptrdiff_t, Lisp_Object *),
+ int howmany, jit_value_t scratch, jit_value_t *stack)
+{
+ jit_value_t args[2];
+
+ args[0] = jit_value_create_nint_constant (func, ptrdiff_t_type, howmany);
+ args[1] = scratch;
+
+ int i;
+ for (i = 0; i < howmany; ++i)
+ jit_insn_store_relative (func, scratch, i * sizeof (Lisp_Object),
+ stack[1 + i]);
+
+ return jit_insn_call_native (func, name, (void *) callee,
+ callN_signature, args, 2, JIT_CALL_NOTHROW);
+}
+
+static jit_value_t
+compile_next_handlerlist (jit_function_t func)
+{
+ jit_value_t current_thread = compile_current_thread (func);
+ jit_value_t hlist_ptr
+ = jit_insn_load_relative (func, current_thread,
+ offsetof (struct thread_state,
+ m_handlerlist),
+ jit_type_void_ptr);
+ jit_value_t next
+ = jit_insn_load_relative (func, hlist_ptr,
+ offsetof (struct handler, next),
+ jit_type_void_ptr);
+ jit_insn_store_relative (func, current_thread,
+ offsetof (struct thread_state,
+ m_handlerlist),
+ next);
+
+ return hlist_ptr;
+}
+
+#define COMPILE_CALLN(FUNC, N) \
+ do { \
+ jit_value_t result; \
+ DISCARD (N); \
+ result = compile_callN (func, # FUNC, FUNC, \
+ N, scratch, &stack[stack_pointer]); \
+ if (N > scratch_slots_needed) \
+ scratch_slots_needed = N; \
+ PUSH (result); \
+ } while (0)
+
+static void
+bcall0 (Lisp_Object f)
+{
+ if (FUNCTIONP (f))
+ Ffuncall (1, &f);
+}
+
+static Lisp_Object
+native_save_window_excursion (Lisp_Object v1)
+{
+ ptrdiff_t count1 = SPECPDL_INDEX ();
+ record_unwind_protect (restore_window_configuration,
+ Fcurrent_window_configuration (Qnil));
+ v1 = Fprogn (v1);
+ unbind_to (count1, v1);
+ return v1;
+}
+
+static Lisp_Object
+native_temp_output_buffer_setup (Lisp_Object x)
+{
+ CHECK_STRING (x);
+ temp_output_buffer_setup (SSDATA (x));
+ return Vstandard_output;
+}
+
+static Lisp_Object
+unbind_n (int val)
+{
+ return unbind_to (SPECPDL_INDEX () - val, Qnil);
+}
+
+static void
+wrong_number_of_arguments (int mandatory, int nonrest, int nargs)
+{
+ Fsignal (Qwrong_number_of_arguments,
+ list2 (Fcons (make_fixnum (mandatory), make_fixnum (nonrest)),
+ make_fixnum (nargs)));
+}
+
+struct pc_list
+{
+ /* PC at which to (re-)start compilation. */
+ int pc;
+ /* Saved stack pointer. */
+ int stack_pointer;
+ struct pc_list *next;
+};
+
+#define PUSH_PC(insn) \
+ do { \
+ struct pc_list *new = xmalloc (sizeof (struct pc_list)); \
+ new->pc = insn; \
+ new->stack_pointer = stack_pointer; \
+ new->next = pc_list; \
+ pc_list = new; \
+ } while (0)
+
+#define COMPILE_BUFFER_INT(FIELD) \
+ compile_buffer_int (func, offsetof (struct buffer, FIELD))
+
+#define COMPARE_BUFFER_INTS(FIELD1, FIELD2) \
+ compare_buffer_ints (func, \
+ offsetof (struct buffer, FIELD1), \
+ offsetof (struct buffer, FIELD2))
+
+static bool
+find_hash_min_max_pc (struct Lisp_Hash_Table *htab,
+ EMACS_INT *min_pc, EMACS_INT *max_pc)
+{
+ for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (htab); ++i)
+ if (!NILP (HASH_HASH (htab, i)))
+ {
+ Lisp_Object pc = HASH_VALUE (htab, i);
+ if (!FIXNUMP (pc))
+ return false;
+ EMACS_INT pcval = XFIXNUM (pc);
+ if (pcval < *min_pc)
+ *min_pc = pcval;
+ if (pcval > *max_pc)
+ *max_pc = pcval;
+ }
+
+ ++*max_pc;
+ return true;
+}
+
+static struct subr_function *
+compile (ptrdiff_t bytestr_length, unsigned char *bytestr_data,
+ EMACS_INT stack_depth, Lisp_Object *vectorp,
+ ptrdiff_t vector_size, Lisp_Object args_template)
+{
+ int type;
+ struct pc_list *pc_list = NULL;
+
+ /* Note that any error before this is attached to the function must
+ free this object. */
+ struct subr_function *result = xmalloc (sizeof (struct subr_function));
+ result->min_args = 0;
+ result->max_args = MANY;
+
+ jit_type_t function_signature = compiled_signature;
+
+ bool parse_args = true;
+ if (FIXNUMP (args_template))
+ {
+ ptrdiff_t at = XFIXNUM (args_template);
+ bool rest = (at & 128) != 0;
+ int mandatory = at & 127;
+ ptrdiff_t nonrest = at >> 8;
+
+ /* Always set this correctly so that funcall_subr will do some
+ checking for us. */
+ result->min_args = mandatory;
+
+ if (!rest && nonrest < SUBR_MAX_ARGS)
+ {
+ result->max_args = nonrest;
+ function_signature = subr_signature[nonrest];
+ parse_args = false;
+ }
+ }
+
+ jit_function_t func = jit_function_create (emacs_jit_context,
+ function_signature);
+ ptrdiff_t pc = 0;
+ jit_value_t *stack = (jit_value_t *) xmalloc (stack_depth
+ * sizeof (jit_value_t));
+ int stack_pointer = -1;
+ jit_label_t *labels = (jit_label_t *) xmalloc (bytestr_length
+ * sizeof (jit_label_t));
+ /* Temporary array used only for switches. */
+ jit_label_t *sw_labels = (jit_label_t *) xmalloc (bytestr_length
+ * sizeof (jit_label_t));
+ int *stack_depths = (int *) xmalloc (bytestr_length * sizeof (int));
+ jit_value_t n_args, arg_vec;
+
+ /* On failure this will also free RESULT. */
+ jit_function_set_meta (func, 0, result, xfree, 0);
+
+ for (int i = 0; i < bytestr_length; ++i)
+ {
+ labels[i] = jit_label_undefined;
+ sw_labels[i] = jit_label_undefined;
+ stack_depths[i] = -1;
+ }
+
+ for (int i = 0; i < stack_depth; ++i)
+ stack[i] = jit_value_create (func, jit_type_void_ptr);
+
+ /* This is a placeholder; once we know how much space we'll need, we
+ will allocate it and move it into place at the start of the
+ function. */
+ jit_value_t scratch = jit_value_create (func, jit_type_void_ptr);
+ int scratch_slots_needed = 0;
+
+ /* State needed if we need to emit a call to
+ wrong_type_argument. */
+ bool called_wtype = false;
+ jit_label_t wtype_label = jit_label_undefined;
+ jit_value_t wtype_arg = jit_value_create (func, jit_type_void_ptr);
+
+ jit_label_t argfail = jit_label_undefined;
+ bool need_argfail = false;
+ jit_value_t mandatory_val, nonrest_val;
+
+ if (!parse_args)
+ {
+ /* We can emit function that doesn't need to manually decipher
+ its arguments. */
+ ptrdiff_t at = XFIXNUM (args_template);
+ ptrdiff_t nonrest = at >> 8;
+
+ for (ptrdiff_t i = 0; i < nonrest; ++i)
+ PUSH (jit_value_get_param (func, i));
+ }
+ else
+ {
+ /* Prologue. */
+ n_args = jit_value_get_param (func, 0);
+ arg_vec = jit_value_get_param (func, 1);
+
+ if (FIXNUMP (args_template))
+ {
+ ptrdiff_t at = XFIXNUM (args_template);
+ bool rest = (at & 128) != 0;
+ int mandatory = at & 127;
+ ptrdiff_t nonrest = at >> 8;
+
+ mandatory_val
+ = jit_value_create_long_constant (func, ptrdiff_t_type, mandatory);
+ nonrest_val
+ = jit_value_create_nint_constant (func, ptrdiff_t_type, nonrest);
+
+ /* If there are no rest arguments and we have more than the
+ maximum, error. Note that funcall_subr ensures that, no
+ matter what, we'll never see fewer than the minimum
+ number of arguments. */
+ if (!rest)
+ {
+ jit_value_t compare = jit_insn_gt (func, n_args, nonrest_val);
+ jit_insn_branch_if (func, compare, &argfail);
+ need_argfail = true;
+ }
+
+ /* Load mandatory arguments. */
+ for (ptrdiff_t i = 0; i < mandatory; ++i)
+ {
+ jit_value_t loaded
+ = jit_insn_load_relative (func, arg_vec, i * sizeof
(Lisp_Object),
+ jit_type_void_ptr);
+ jit_insn_store (func, stack[i], loaded);
+ }
+
+ /* &optional arguments are a bit weirder since we can't refer to
+ the appropriate stack slot by index at runtime. */
+ if (nonrest > mandatory)
+ {
+ jit_value_t qnil = CONSTANT (func, Qnil);
+ jit_label_t *opt_labels
+ = (jit_label_t *) xmalloc ((nonrest - mandatory)
+ * sizeof (jit_label_t));
+ jit_label_t opts_done = jit_label_undefined;
+
+ for (ptrdiff_t i = mandatory; i < nonrest; ++i)
+ {
+ opt_labels[i - mandatory] = jit_label_undefined;
+
+ jit_value_t this_arg
+ = jit_value_create_nint_constant (func, jit_type_sys_int,
i);
+ jit_value_t cmp = jit_insn_le (func, n_args, this_arg);
+ /* If this argument wasn't found, then neither are the
+ subsequent ones; so branch into the correct spot in a
+ series of loads of Qnil. */
+ jit_insn_branch_if (func, cmp, &opt_labels[i - mandatory]);
+
+ jit_value_t loaded
+ = jit_insn_load_relative (func, arg_vec,
+ i * sizeof (Lisp_Object),
+ jit_type_void_ptr);
+ jit_insn_store (func, stack[i], loaded);
+ }
+
+ jit_insn_branch (func, &opts_done);
+
+ for (ptrdiff_t i = mandatory; i < nonrest; ++i)
+ {
+ jit_insn_label (func, &opt_labels[i - mandatory]);
+ jit_insn_store (func, stack[i], qnil);
+ }
+
+ jit_insn_label (func, &opts_done);
+ xfree (opt_labels);
+ }
+
+ stack_pointer = nonrest - 1;
+
+ /* Now handle rest arguments, if any. */
+ if (rest)
+ {
+ jit_label_t no_rest = jit_label_undefined;
+ jit_value_t cmp = jit_insn_lt (func, nonrest_val, n_args);
+ jit_insn_branch_if_not (func, cmp, &no_rest);
+
+ jit_value_t vec_addr
+ = jit_insn_load_elem_address (func, arg_vec, nonrest_val,
+ jit_type_void_ptr);
+ jit_value_t new_args
+ = jit_insn_sub (func, n_args, nonrest_val);
+
+ jit_value_t args[2] = { new_args, vec_addr };
+ jit_value_t listval
+ = jit_insn_call_native (func, "list", (void *) Flist,
+ callN_signature,
+ args, 2, JIT_CALL_NOTHROW);
+ PUSH (listval);
+ jit_insn_branch (func, &labels[0]);
+
+ /* Since we emitted a branch. */
+ --stack_pointer;
+ jit_insn_label (func, &no_rest);
+ jit_value_t qnil = CONSTANT (func, Qnil);
+ PUSH (qnil);
+ }
+
+ /* Fall through to the main body. */
+ }
+ }
+
+ for (;;)
+ {
+ if (pc == bytestr_length)
+ {
+ /* Falling off the end would be bad. */
+ goto fail;
+ }
+ else if (pc != -1 && (stack_depths[pc] != -1))
+ {
+ /* We've already compiled this code, and we're expecting to
+ fall through. So, emit a goto and then resume work at
+ some other PC. */
+ jit_insn_branch (func, &labels[pc]);
+ pc = -1;
+ }
+
+ /* If we don't have a PC currently, pop a new one from the list
+ and work there. */
+ while (pc == -1 && pc_list != NULL)
+ {
+ struct pc_list *next;
+
+ pc = pc_list->pc;
+ stack_pointer = pc_list->stack_pointer;
+ next = pc_list->next;
+ xfree (pc_list);
+ pc_list = next;
+
+ if (stack_depths[pc] == -1)
+ {
+ /* Work on this one. */
+ stack_depths[pc] = stack_pointer + 1;
+ break;
+ }
+ else if (stack_depths[pc] == stack_pointer + 1)
+ {
+ /* Already compiled this. */
+ pc = -1;
+ }
+ else
+ {
+ /* Oops - failure. */
+ goto fail;
+ }
+ }
+
+ if (pc == -1 && pc_list == NULL)
+ {
+ /* No more blocks to examine. */
+ break;
+ }
+
+ jit_insn_label (func, &labels[pc]);
+
+ int op = FETCH;
+ switch (op)
+ {
+ case Bvarref7:
+ op = FETCH2;
+ goto varref;
+
+ case Bvarref:
+ case Bvarref1:
+ case Bvarref2:
+ case Bvarref3:
+ case Bvarref4:
+ case Bvarref5:
+ op -= Bvarref;
+ goto varref;
+
+ case Bvarref6:
+ op = FETCH;
+ varref:
+ {
+ jit_value_t sym, result;
+
+ sym = CONSTANT (func, vectorp[op]);
+ result = jit_insn_call_native (func, "symbol-value",
+ (void *) Fsymbol_value,
+ unary_signature, &sym, 1,
+ JIT_CALL_NOTHROW);
+ PUSH (result);
+ break;
+ }
+
+ case Bcar:
+ car_or_cdr (func, TOP, offsetof (struct Lisp_Cons, u.s.car),
+ &labels[pc], false,
+ &called_wtype, &wtype_label, wtype_arg);
+ break;
+
+ case Beq:
+ {
+ jit_value_t v1 = POP;
+ jit_value_t compare = jit_insn_eq (func, v1, TOP);
+ emit_qnil_or_qt (func, bytestr_data, pc, compare, TOP, labels);
+ break;
+ }
+
+ case Bmemq:
+ {
+ jit_value_t v1 = POP;
+ compile_binary (func, "memq", Fmemq, TOP, v1);
+ break;
+ }
+
+ case Bcdr:
+ car_or_cdr (func, TOP, offsetof (struct Lisp_Cons, u.s.u.cdr),
+ &labels[pc], false,
+ &called_wtype, &wtype_label, wtype_arg);
+ break;
+
+ case Bvarset:
+ case Bvarset1:
+ case Bvarset2:
+ case Bvarset3:
+ case Bvarset4:
+ case Bvarset5:
+ op -= Bvarset;
+ goto varset;
+
+ case Bvarset7:
+ op = FETCH2;
+ goto varset;
+
+ case Bvarset6:
+ op = FETCH;
+ varset:
+ {
+ jit_value_t args[4];
+
+ args[0] = CONSTANT (func, vectorp[op]);
+ args[1] = POP;
+ args[2] = CONSTANT (func, Qnil);
+ args[3] = jit_value_create_nint_constant (func, jit_type_sys_int,
+ SET_INTERNAL_SET);
+
+ jit_insn_call_native (func, "set_internal", (void *) set_internal,
+ set_internal_signature, args, 4,
+ JIT_CALL_NOTHROW);
+ }
+ break;
+
+ case Bdup:
+ {
+ jit_value_t v1 = TOP;
+ PUSH (v1);
+ break;
+ }
+
+ /* ------------------ */
+
+ case Bvarbind6:
+ op = FETCH;
+ goto varbind;
+
+ case Bvarbind7:
+ op = FETCH2;
+ goto varbind;
+
+ case Bvarbind:
+ case Bvarbind1:
+ case Bvarbind2:
+ case Bvarbind3:
+ case Bvarbind4:
+ case Bvarbind5:
+ op -= Bvarbind;
+ varbind:
+ {
+ jit_value_t vals[2];
+
+ vals[0] = CONSTANT (func, vectorp[op]);
+ vals[1] = POP;
+
+ jit_insn_call_native (func, "specbind", (void *) specbind,
+ specbind_signature, vals, 2,
+ JIT_CALL_NOTHROW);
+ break;
+ }
+
+ case Bcall6:
+ op = FETCH;
+ goto docall;
+
+ case Bcall7:
+ op = FETCH2;
+ goto docall;
+
+ case Bcall:
+ case Bcall1:
+ case Bcall2:
+ case Bcall3:
+ case Bcall4:
+ case Bcall5:
+ op -= Bcall;
+ docall:
+ {
+ COMPILE_CALLN (Ffuncall, op + 1);
+ break;
+ }
+
+ case Bunbind6:
+ op = FETCH;
+ goto dounbind;
+
+ case Bunbind7:
+ op = FETCH2;
+ goto dounbind;
+
+ case Bunbind:
+ case Bunbind1:
+ case Bunbind2:
+ case Bunbind3:
+ case Bunbind4:
+ case Bunbind5:
+ op -= Bunbind;
+ dounbind:
+ {
+ jit_value_t val = jit_value_create_nint_constant (func,
+ jit_type_sys_int,
+ op);
+ jit_insn_call_native (func, "unbind_n", (void *) unbind_n,
+ unbind_n_signature, &val, 1,
+ JIT_CALL_NOTHROW);
+ }
+ break;
+
+ case Bgoto:
+ op = FETCH2;
+ /* This looks funny but it circumvents the code above that
+ handles the case where fall-through actually requires a
+ branch. */
+ PUSH_PC (op);
+ pc = -1;
+ jit_insn_branch (func, &labels[op]);
+ break;
+
+ case Bgotoifnil:
+ {
+ jit_value_t v1 = POP;
+ jit_value_t compare = eq_nil (func, v1);
+ op = FETCH2;
+ PUSH_PC (op);
+ jit_insn_branch_if (func, compare, &labels[op]);
+ break;
+ }
+
+ case Bgotoifnonnil:
+ {
+ jit_value_t val = POP;
+ jit_value_t compare = eq_nil (func, val);
+ op = FETCH2;
+ PUSH_PC (op);
+ jit_insn_branch_if_not (func, compare, &labels[op]);
+ break;
+ }
+
+ case Bgotoifnilelsepop:
+ {
+ jit_value_t v1 = TOP;
+ jit_value_t compare = eq_nil (func, v1);
+ op = FETCH2;
+ PUSH_PC (op);
+ jit_insn_branch_if (func, compare, &labels[op]);
+ DISCARD (1);
+ break;
+ }
+ break;
+
+ case Bgotoifnonnilelsepop:
+ {
+ jit_value_t v1 = TOP;
+ jit_value_t compare = eq_nil (func, v1);
+ op = FETCH2;
+ PUSH_PC (op);
+ jit_insn_branch_if_not (func, compare, &labels[op]);
+ DISCARD (1);
+ break;
+ }
+ break;
+
+ case BRgoto:
+ {
+ op = FETCH - 128;
+ op += pc;
+ /* This looks funny but it circumvents the code above that
+ handles the case where fall-through actually requires a
+ branch. */
+ PUSH_PC (op);
+ pc = -1;
+ jit_insn_branch (func, &labels[op]);
+ break;
+ }
+
+ case BRgotoifnil:
+ {
+ jit_value_t v1 = POP;
+ jit_value_t compare = eq_nil (func, v1);
+ op = FETCH - 128;
+ op += pc;
+ PUSH_PC (op);
+ jit_insn_branch_if (func, compare, &labels[op]);
+ break;
+ }
+
+ case BRgotoifnonnil:
+ {
+ jit_value_t v1 = POP;
+ jit_value_t compare = eq_nil (func, v1);
+ op = FETCH - 128;
+ op += pc;
+ PUSH_PC (op);
+ jit_insn_branch_if_not (func, compare, &labels[op]);
+ break;
+ }
+
+ case BRgotoifnilelsepop:
+ {
+ jit_value_t v1 = TOP;
+ jit_value_t compare = eq_nil (func, v1);
+ op = FETCH - 128;
+ op += pc;
+ PUSH_PC (op);
+ jit_insn_branch_if (func, compare, &labels[op]);
+ DISCARD (1);
+ break;
+ }
+
+ case BRgotoifnonnilelsepop:
+ {
+ jit_value_t v1 = TOP;
+ jit_value_t compare = eq_nil (func, v1);
+ op = FETCH - 128;
+ op += pc;
+ PUSH_PC (op);
+ jit_insn_branch_if_not (func, compare, &labels[op]);
+ DISCARD (1);
+ break;
+ }
+
+ case Breturn:
+ jit_insn_return (func, TOP);
+ pc = -1;
+ break;
+
+ case Bdiscard:
+ DISCARD (1);
+ break;
+
+ case Bsave_excursion:
+ jit_insn_call_native (func, "record_unwind_protect_excursion",
+ (void *) record_unwind_protect_excursion,
+ record_unwind_protect_excursion_signature,
+ NULL, 0, JIT_CALL_NOTHROW);
+ break;
+
+ case Bsave_current_buffer: /* Obsolete since ??. */
+ case Bsave_current_buffer_1:
+ jit_insn_call_native (func, "record_unwind_current_buffer",
+ (void *) record_unwind_current_buffer,
+ void_void_signature,
+ NULL, 0, JIT_CALL_NOTHROW);
+ break;
+
+ case Bsave_window_excursion: /* Obsolete since 24.1. */
+ {
+ compile_unary (func, "save-window-excursion",
+ native_save_window_excursion, TOP);
+ break;
+ }
+
+ case Bsave_restriction:
+ {
+ jit_value_t vals[2];
+
+ vals[0] = CONSTANT (func, save_restriction_restore);
+ vals[1] = jit_insn_call_native (func, "save_restriction_save",
+ (void *) save_restriction_save,
+ void_void_signature,
+ NULL, 0, JIT_CALL_NOTHROW);
+ jit_insn_call_native (func, "record_unwind_protect",
+ (void *) record_unwind_protect,
+ record_unwind_protect_signature,
+ vals, 2, JIT_CALL_NOTHROW);
+ break;
+ }
+
+ case Bcatch: /* Obsolete since 24.4. */
+ {
+ jit_value_t args[3];
+
+ args[1] = CONSTANT (func, eval_sub);
+ args[2] = POP;
+ args[0] = POP;
+
+ /* FIXME this lies about the signature. */
+ jit_value_t result = jit_insn_call_native (func, "internal_catch",
+ internal_catch,
+ ternary_signature,
+ args, 3,
+ JIT_CALL_NOTHROW);
+ PUSH (result);
+ break;
+ }
+
+ case Bpushcatch: /* New in 24.4. */
+ type = CATCHER;
+ goto pushhandler;
+ case Bpushconditioncase: /* New in 24.4. */
+ type = CONDITION_CASE;
+ pushhandler:
+ {
+ jit_value_t args[2];
+ jit_value_t handler, cond;
+ int handler_pc = FETCH2;
+
+ args[0] = POP;
+ args[1] = jit_value_create_nint_constant (func, jit_type_sys_int,
+ type);
+
+ handler = jit_insn_call_native (func, "push_handler", push_handler,
+ push_handler_signature,
+ args, 2, JIT_CALL_NOTHROW);
+ jit_value_t jmp
+ = jit_insn_add_relative (func, handler,
+ offsetof (struct handler, jmp));
+
+ /* FIXME probably should be using the same as the rest of
+ emacs. */
+ cond = jit_insn_call_native (func, "sys_setjmp", setjmp,
+ setjmp_signature,
+ &jmp, 1, JIT_CALL_NOTHROW);
+ PUSH_PC (pc);
+ jit_insn_branch_if_not (func, cond, &labels[pc]);
+
+ /* Something threw to here. */
+ jit_value_t hlist = compile_next_handlerlist (func);
+
+ jit_value_t val
+ = jit_insn_load_relative (func, hlist,
+ offsetof (struct handler, val),
+ jit_type_void_ptr);
+
+ PUSH (val);
+ PUSH_PC (handler_pc);
+ jit_insn_branch (func, &labels[handler_pc]);
+
+ pc = -1;
+ break;
+ }
+
+ case Bpophandler: /* New in 24.4. */
+ {
+ compile_next_handlerlist (func);
+ break;
+ }
+
+ case Bunwind_protect: /* FIXME: avoid closure for lexbind. */
+ {
+ jit_value_t args[2];
+
+ args[0] = CONSTANT (func, bcall0);
+ args[1] = POP;
+ jit_insn_call_native (func, "record_unwind_protect",
+ (void *) record_unwind_protect,
+ record_unwind_protect_signature,
+ args, 2, JIT_CALL_NOTHROW);
+ break;
+ }
+
+ case Bcondition_case: /* Obsolete since 24.4. */
+ {
+ jit_value_t handlers = POP, body = POP;
+ compile_ternary (func, "condition-case",
+ internal_lisp_condition_case, TOP,
+ body, handlers);
+ break;
+ }
+
+ case Btemp_output_buffer_setup: /* Obsolete since 24.1. */
+ {
+ compile_unary (func, "temp-output-buffer-setup",
+ native_temp_output_buffer_setup, TOP);
+ break;
+ }
+
+ case Btemp_output_buffer_show: /* Obsolete since 24.1. */
+ {
+ jit_value_t v1 = POP;
+ jit_value_t v2 = TOP;
+ jit_value_t tem;
+
+ jit_insn_call_native (func, "temp_output_buffer_show",
+ (void *) temp_output_buffer_show,
+ temp_output_buffer_show_signature,
+ &v2, 1, JIT_CALL_NOTHROW);
+ jit_insn_store (func, TOP, v1);
+
+ tem = jit_value_create_nint_constant (func, jit_type_sys_int, 1);
+ jit_insn_call_native (func, "unbind_n", (void *) unbind_n,
+ unbind_n_signature, &tem, 1,
+ JIT_CALL_NOTHROW);
+ break;
+ }
+
+ case Bnth:
+ {
+ jit_value_t v2 = POP;
+ compile_binary (func, "nth", Fnth, TOP, v2);
+ break;
+ }
+
+ case Bsymbolp:
+ {
+ jit_value_t compare = compare_type (func, TOP, Lisp_Symbol);
+ emit_qnil_or_qt (func, bytestr_data, pc, compare, TOP, labels);
+ break;
+ }
+
+ case Bconsp:
+ {
+ jit_value_t compare = compare_type (func, TOP, Lisp_Cons);
+ emit_qnil_or_qt (func, bytestr_data, pc, compare, TOP, labels);
+ break;
+ }
+
+ case Bstringp:
+ {
+ jit_value_t compare = compare_type (func, TOP, Lisp_String);
+ emit_qnil_or_qt (func, bytestr_data, pc, compare, TOP, labels);
+ break;
+ }
+
+ case Blistp:
+ {
+ jit_value_t tem, nilval;
+ jit_label_t not_a_cons = jit_label_undefined;
+ jit_label_t not_nil = jit_label_undefined;
+
+ jit_value_t is_cons = compare_type (func, TOP, Lisp_Cons);
+ jit_insn_branch_if_not (func, is_cons, ¬_a_cons);
+
+ /* Is a cons. */
+ tem = CONSTANT (func, Qt);
+ jit_insn_store (func, TOP, tem);
+ jit_insn_branch (func, &labels[pc]);
+
+ jit_insn_label (func, ¬_a_cons);
+
+ nilval = CONSTANT (func, Qnil);
+ tem = jit_insn_eq (func, TOP, nilval);
+
+ jit_insn_branch_if_not (func, tem, ¬_nil);
+
+ /* Is nil. */
+ tem = CONSTANT (func, Qt);
+ jit_insn_store (func, TOP, tem);
+ jit_insn_branch (func, &labels[pc]);
+
+ jit_insn_label (func, ¬_nil);
+ jit_insn_store (func, TOP, nilval);
+ }
+ break;
+
+ case Bnot:
+ {
+ jit_value_t compare = eq_nil (func, TOP);
+ emit_qnil_or_qt (func, bytestr_data, pc, compare, TOP, labels);
+ break;
+ }
+
+ case Bcons:
+ {
+ jit_value_t v1 = POP;
+ compile_binary (func, "cons", Fcons, TOP, v1);
+ break;
+ }
+
+ case BlistN:
+ op = FETCH;
+ goto make_list;
+
+ case Blist1:
+ case Blist2:
+ case Blist3:
+ case Blist4:
+ op = op + 1 - Blist1;
+ make_list:
+ {
+ jit_value_t args[2];
+
+ int i;
+ args[1] = CONSTANT (func, Qnil);
+
+ for (i = 0; i < op; ++i)
+ {
+ args[0] = POP;
+ args[1] = jit_insn_call_native (func, "cons", (void *) Fcons,
+ binary_signature, args, 2,
+ JIT_CALL_NOTHROW);
+ }
+
+ PUSH (args[1]);
+ break;
+ }
+
+ case Blength:
+ compile_unary (func, "length", Flength, TOP);
+ break;
+
+ case Baref:
+ {
+ jit_value_t v1 = POP;
+ compile_binary (func, "aref", Faref, TOP, v1);
+ break;
+ }
+
+ case Baset:
+ {
+ jit_value_t v2 = POP, v1 = POP;
+ compile_ternary (func, "aset", Faset, TOP, v1, v2);
+ break;
+ }
+
+ case Bsymbol_value:
+ compile_unary (func, "symbol-value", Fsymbol_value, TOP);
+ break;
+
+ case Bsymbol_function:
+ compile_unary (func, "symbol-function", Fsymbol_function, TOP);
+ break;
+
+ case Bset:
+ {
+ jit_value_t v1 = POP;
+ compile_binary (func, "set", Fset, TOP, v1);
+ break;
+ }
+
+ case Bfset:
+ {
+ jit_value_t v1 = POP;
+ compile_binary (func, "fset", Ffset, TOP, v1);
+ break;
+ }
+
+ case Bget:
+ {
+ jit_value_t v1 = POP;
+ compile_binary (func, "get", Fget, TOP, v1);
+ break;
+ }
+
+ case Bsubstring:
+ {
+ jit_value_t v2 = POP, v1 = POP;
+ compile_ternary (func, "substring", Fsubstring, TOP, v1, v2);
+ break;
+ }
+
+ case Bconcat2:
+ {
+ COMPILE_CALLN (Fconcat, 2);
+ break;
+ }
+
+ case Bconcat3:
+ {
+ COMPILE_CALLN (Fconcat, 3);
+ break;
+ }
+
+ case Bconcat4:
+ {
+ COMPILE_CALLN (Fconcat, 4);
+ break;
+ }
+
+ case BconcatN:
+ {
+ op = FETCH;
+ COMPILE_CALLN (Fconcat, op);
+ break;
+ }
+
+ case Bsub1:
+ unary_intmath (func, TOP, SUB1, &labels[pc]);
+ break;
+
+ case Badd1:
+ unary_intmath (func, TOP, ADD1, &labels[pc]);
+ break;
+
+ case Beqlsign:
+ {
+ jit_value_t v1 = POP;
+ compile_arithcompare (func, "=", TOP, v1, ARITH_EQUAL);
+ break;
+ }
+
+ case Bgtr:
+ {
+ jit_value_t v1 = POP;
+ compile_arithcompare (func, ">", TOP, v1, ARITH_GRTR);
+ break;
+ }
+
+ case Blss:
+ {
+ jit_value_t v1 = POP;
+ compile_arithcompare (func, "<", TOP, v1, ARITH_LESS);
+ break;
+ }
+
+ case Bleq:
+ {
+ jit_value_t v1 = POP;
+ compile_arithcompare (func, "<=", TOP, v1, ARITH_LESS_OR_EQUAL);
+ break;
+ }
+
+ case Bgeq:
+ {
+ jit_value_t v1 = POP;
+ compile_arithcompare (func, ">=", TOP, v1, ARITH_GRTR_OR_EQUAL);
+ break;
+ }
+
+ case Bdiff:
+ {
+ COMPILE_CALLN (Fminus, 2);
+ break;
+ }
+
+ case Bnegate:
+ unary_intmath (func, TOP, NEGATE, &labels[pc]);
+ break;
+
+ case Bplus:
+ {
+ COMPILE_CALLN (Fplus, 2);
+ break;
+ }
+
+ case Bmax:
+ {
+ COMPILE_CALLN (Fmax, 2);
+ break;
+ }
+
+ case Bmin:
+ {
+ COMPILE_CALLN (Fmin, 2);
+ break;
+ }
+
+ case Bmult:
+ {
+ COMPILE_CALLN (Ftimes, 2);
+ break;
+ }
+
+ case Bquo:
+ {
+ COMPILE_CALLN (Fquo, 2);
+ break;
+ }
+
+ case Brem:
+ {
+ jit_value_t v1 = POP;
+ compile_binary (func, "rem", Frem, TOP, v1);
+ break;
+ }
+
+ case Bpoint:
+ PUSH (COMPILE_BUFFER_INT (pt));
+ break;
+
+ case Bgoto_char:
+ compile_unary (func, "goto-char", Fgoto_char, TOP);
+ break;
+
+ case Binsert:
+ {
+ COMPILE_CALLN (Finsert, 1);
+ break;
+ }
+
+ case BinsertN:
+ {
+ op = FETCH;
+ COMPILE_CALLN (Finsert, op);
+ break;
+ }
+
+ case Bpoint_max:
+ PUSH (COMPILE_BUFFER_INT (zv));
+ break;
+
+ case Bpoint_min:
+ PUSH (COMPILE_BUFFER_INT (begv));
+ break;
+
+ case Bchar_after:
+ compile_unary (func, "char-after", Fchar_after, TOP);
+ break;
+
+ case Bfollowing_char:
+ PUSH (compile_nullary (func, "following-char", Ffollowing_char));
+ break;
+
+ case Bpreceding_char:
+ PUSH (compile_nullary (func, "previous-char", Fprevious_char));
+ break;
+
+ case Bcurrent_column:
+ PUSH (compile_nullary (func, "current-column", Fcurrent_column));
+ break;
+
+ case Bindent_to:
+ {
+ jit_value_t tem = CONSTANT (func, Qnil);
+ compile_binary (func, "indent-to", Findent_to, TOP, tem);
+ break;
+ }
+
+ case Beolp:
+ PUSH (compile_nullary (func, "eolp", Feolp));
+ break;
+
+ case Beobp:
+ {
+ jit_value_t compare = COMPARE_BUFFER_INTS (pt, zv);
+ ++stack_pointer;
+ emit_qnil_or_qt (func, bytestr_data, pc, compare, TOP, labels);
+ break;
+ }
+
+ case Bbolp:
+ PUSH (compile_nullary (func, "bolp", Fbolp));
+ break;
+
+ case Bbobp:
+ {
+ jit_value_t compare = COMPARE_BUFFER_INTS (pt, begv);
+ ++stack_pointer;
+ emit_qnil_or_qt (func, bytestr_data, pc, compare, TOP, labels);
+ break;
+ }
+
+ case Bcurrent_buffer:
+ PUSH (compile_nullary (func, "current-buffer", Fcurrent_buffer));
+ break;
+
+ case Bset_buffer:
+ compile_unary (func, "set-buffer", Fset_buffer, TOP);
+ break;
+
+ case Binteractive_p: /* Obsolete since 24.1. */
+ {
+ jit_value_t arg = CONSTANT (func, Qinteractive_p);
+ jit_value_t result = jit_insn_call_native (func, "interactive-p",
+ (void *) call0,
+ unary_signature, &arg, 1,
+ JIT_CALL_NOTHROW);
+ PUSH (result);
+ break;
+ }
+
+ case Bforward_char:
+ compile_unary (func, "forward-char", Fforward_char, TOP);
+ break;
+
+ case Bforward_word:
+ compile_unary (func, "forward-word", Fforward_word, TOP);
+ break;
+
+ case Bskip_chars_forward:
+ {
+ jit_value_t v1 = POP;
+ compile_binary (func, "skip-chars-forward", Fskip_chars_forward,
+ TOP, v1);
+ break;
+ }
+
+ case Bskip_chars_backward:
+ {
+ jit_value_t v1 = POP;
+ compile_binary (func, "skip-chars-backward", Fskip_chars_backward,
+ TOP, v1);
+ break;
+ }
+
+ case Bforward_line:
+ compile_unary (func, "forward-line", Fforward_line, TOP);
+ break;
+
+ case Bchar_syntax:
+ compile_unary (func, "char-syntax", Fchar_syntax, TOP);
+ break;
+
+ case Bbuffer_substring:
+ {
+ jit_value_t v1 = POP;
+ compile_binary (func, "buffer-substring", Fbuffer_substring,
+ TOP, v1);
+ break;
+ }
+
+ case Bdelete_region:
+ {
+ jit_value_t v1 = POP;
+ compile_binary (func, "delete-region", Fdelete_region, TOP, v1);
+ break;
+ }
+
+ case Bnarrow_to_region:
+ {
+ jit_value_t v1 = POP;
+ compile_binary (func, "narrow-to-region", Fnarrow_to_region,
+ TOP, v1);
+ break;
+ }
+
+ case Bwiden:
+ PUSH (compile_nullary (func, "widen", Fwiden));
+ break;
+
+ case Bend_of_line:
+ compile_unary (func, "end-of-line", Fend_of_line, TOP);
+ break;
+
+ case Bset_marker:
+ {
+ jit_value_t v2 = POP, v1 = POP;
+ compile_ternary (func, "set-marker", Fset_marker, TOP, v1, v2);
+ break;
+ }
+
+ case Bmatch_beginning:
+ compile_unary (func, "match-beginning", Fmatch_beginning, TOP);
+ break;
+
+ case Bmatch_end:
+ compile_unary (func, "match-end", Fmatch_end, TOP);
+ break;
+
+ case Bupcase:
+ compile_unary (func, "upcase", Fupcase, TOP);
+ break;
+
+ case Bdowncase:
+ compile_unary (func, "downcase", Fdowncase, TOP);
+ break;
+
+ case Bstringeqlsign:
+ {
+ jit_value_t v1 = POP;
+ compile_binary (func, "string=", Fstring_equal, TOP, v1);
+ break;
+ }
+
+ case Bstringlss:
+ {
+ jit_value_t v1 = POP;
+ compile_binary (func, "string<", Fstring_lessp, TOP, v1);
+ break;
+ }
+
+ case Bequal:
+ {
+ jit_value_t v1 = POP;
+ compile_binary (func, "equal", Fequal, TOP, v1);
+ break;
+ }
+
+ case Bnthcdr:
+ {
+ jit_value_t v1 = POP;
+ compile_binary (func, "nthcdr", Fnthcdr, TOP, v1);
+ break;
+ }
+
+ case Belt:
+ {
+ jit_value_t v1 = POP;
+ compile_binary (func, "elt", Felt, TOP, v1);
+ break;
+ }
+
+ case Bmember:
+ {
+ jit_value_t v1 = POP;
+ compile_binary (func, "member", Fmember, TOP, v1);
+ break;
+ }
+
+ case Bassq:
+ {
+ jit_value_t v1 = POP;
+ compile_binary (func, "assq", Fassq, TOP, v1);
+ break;
+ }
+
+ case Bnreverse:
+ compile_unary (func, "nreverse", Fnreverse, TOP);
+ break;
+
+ case Bsetcar:
+ {
+ jit_value_t v1 = POP;
+ compile_binary (func, "setcar", Fsetcar, TOP, v1);
+ break;
+ }
+
+ case Bsetcdr:
+ {
+ jit_value_t v1 = POP;
+ compile_binary (func, "setcdr", Fsetcdr, TOP, v1);
+ break;
+ }
+
+ case Bcar_safe:
+ car_or_cdr (func, TOP, offsetof (struct Lisp_Cons, u.s.car),
+ &labels[pc], true,
+ &called_wtype, &wtype_label, wtype_arg);
+ break;
+
+ case Bcdr_safe:
+ car_or_cdr (func, TOP, offsetof (struct Lisp_Cons, u.s.u.cdr),
+ &labels[pc], true,
+ &called_wtype, &wtype_label, wtype_arg);
+ break;
+
+ case Bnconc:
+ {
+ COMPILE_CALLN (Fnconc, 2);
+ break;
+ }
+
+ case Bnumberp:
+ {
+ jit_label_t push_t = jit_label_undefined;
+ jit_label_t push_nil = jit_label_undefined;
+
+ jit_value_t val = POP;
+ jit_value_t type;
+ jit_value_t compare = compare_integerp (func, val, &type);
+ jit_insn_branch_if (func, compare, &push_t);
+
+ jit_value_t type_val
+ = jit_value_create_nint_constant (func, jit_type_void_ptr,
+ Lisp_Float);
+ compare = jit_insn_eq (func, type, type_val);
+
+ jit_insn_branch_if (func, compare, &push_t);
+
+ jit_insn_label (func, &push_nil);
+ PUSH (CONSTANT (func, Qnil));
+ jit_insn_branch (func, &labels[pc]);
+
+ --stack_pointer;
+ jit_insn_label (func, &push_t);
+ PUSH (CONSTANT (func, Qt));
+
+ break;
+ }
+
+ case Bintegerp:
+ {
+ jit_value_t compare = compare_integerp (func, TOP, NULL);
+ emit_qnil_or_qt (func, bytestr_data, pc, compare, TOP, labels);
+ break;
+ }
+
+ /* Handy byte-codes for lexical binding. */
+ case Bstack_ref1:
+ case Bstack_ref2:
+ case Bstack_ref3:
+ case Bstack_ref4:
+ case Bstack_ref5:
+ {
+ jit_value_t v1 = stack[stack_pointer - (op - Bstack_ref)];
+ PUSH (v1);
+ break;
+ }
+ case Bstack_ref6:
+ {
+ jit_value_t v1 = stack[stack_pointer - FETCH];
+ PUSH (v1);
+ break;
+ }
+ case Bstack_ref7:
+ {
+ jit_value_t v1 = stack[stack_pointer - FETCH2];
+ PUSH (v1);
+ break;
+ }
+ case Bstack_set:
+ /* stack-set-0 = discard; stack-set-1 = discard-1-preserve-tos. */
+ {
+ jit_value_t tos = POP;
+ op = FETCH;
+ if (op > 0)
+ jit_insn_store (func, stack[stack_pointer + 1 - op], tos);
+ break;
+ }
+ case Bstack_set2:
+ {
+ jit_value_t tos = POP;
+ op = FETCH2;
+ if (op > 0)
+ jit_insn_store (func, stack[stack_pointer + 1 - op], tos);
+ break;
+ }
+ case BdiscardN:
+ op = FETCH;
+ if (op & 0x80)
+ {
+ op &= 0x7F;
+ jit_insn_store (func, stack[stack_pointer - op], TOP);
+ }
+ DISCARD (op);
+ break;
+
+ case Bswitch:
+ /* The cases of Bswitch that we handle (which in theory is
+ all of them) are done in Bconstant, below. This is done
+ due to a design issue with Bswitch -- it should have
+ taken a constant pool index inline, but instead looks for
+ a constant on the stack. */
+ goto fail;
+
+ case Bconstant2:
+ op = FETCH2;
+ goto do_constant;
+
+ default:
+ case Bconstant:
+ {
+ if (op < Bconstant || op > Bconstant + vector_size)
+ goto fail;
+
+ op -= Bconstant;
+
+ do_constant:
+
+ /* See the Bswitch case for commentary. */
+ if (pc >= bytestr_length || bytestr_data[pc] != Bswitch)
+ {
+ jit_value_t c = CONSTANT (func, vectorp[op]);
+ PUSH (c);
+ break;
+ }
+
+ /* We're compiling Bswitch instead. */
+ ++pc;
+ Lisp_Object htab = vectorp[op];
+ struct Lisp_Hash_Table *h = XHASH_TABLE (vectorp[op]);
+
+ /* Minimum and maximum PC values for the table. */
+ EMACS_INT min_pc = bytestr_length, max_pc = 0;
+ if (!find_hash_min_max_pc (h, &min_pc, &max_pc))
+ goto fail;
+
+ jit_value_t args[3];
+ args[0] = POP;
+ args[1] = CONSTANT (func, htab);
+ args[2] = CONSTANT (func, Qnil);
+
+ jit_value_t value
+ = jit_insn_call_native (func, "Fgethash", (void *) Fgethash,
+ ternary_signature, args, 3,
+ JIT_CALL_NOTHROW);
+ jit_value_t compare = jit_insn_eq (func, value, args[2]);
+
+ jit_label_t default_case = jit_function_reserve_label (func);
+ jit_insn_branch_if (func, compare, &default_case);
+
+ /* Note that we know the type because we check it when
+ walking the hash table, and the hash table is
+ (effectively) immutable. */
+ value = to_int (func, value);
+ jit_value_t min_pc_val
+ = jit_value_create_nint_constant (func, jit_type_sys_int,
+ min_pc);
+ value = jit_insn_sub (func, value, min_pc_val);
+
+ /* Initialize switch labels. */
+ for (int i = 0; i < max_pc - min_pc; ++i)
+ sw_labels[i] = default_case;
+
+ /* Fill in the switch table. */
+ for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i)
+ {
+ if (!NILP (HASH_HASH (h, i)))
+ {
+ Lisp_Object pc = HASH_VALUE (h, i);
+ /* This was already checked by
+ find_hash_min_max_pc. */
+ eassert (FIXNUMP (pc));
+ EMACS_INT pcval = XFIXNUM (pc);
+
+ /* Make sure that the label we'll need is defined. */
+ if (labels[pcval] == jit_label_undefined)
+ labels[pcval] = jit_function_reserve_label (func);
+
+ sw_labels[pcval - min_pc] = labels[pcval];
+
+ PUSH_PC (pcval);
+ }
+ }
+
+ jit_insn_jump_table (func, value, sw_labels, max_pc - min_pc);
+ jit_insn_label (func, &default_case);
+ break;
+ }
+ }
+ }
+
+ if (scratch_slots_needed > 0)
+ {
+ jit_label_t init_start = jit_label_undefined;
+ jit_label_t init_end = jit_label_undefined;
+
+ jit_insn_label (func, &init_start);
+ jit_value_t scratch_size
+ = jit_value_create_nint_constant (func, jit_type_sys_int,
+ (scratch_slots_needed
+ * sizeof (Lisp_Object)));
+ jit_value_t allocated = jit_insn_alloca (func, scratch_size);
+ jit_insn_store (func, scratch, allocated);
+ jit_insn_label (func, &init_end);
+
+ jit_insn_move_blocks_to_start (func, init_start, init_end);
+ }
+
+ if (need_argfail)
+ {
+ jit_value_t args[3];
+ jit_insn_label (func, &argfail);
+ args[0] = mandatory_val;
+ args[1] = nonrest_val;
+ args[2] = n_args;
+ jit_insn_call_native (func, "wrong-number-of-arguments",
+ (void *) wrong_number_of_arguments,
+ wrong_number_of_arguments_signature,
+ args, 3, JIT_CALL_NORETURN);
+ }
+
+ if (called_wtype)
+ compile_wrong_type_argument (func, &wtype_label, wtype_arg);
+
+ if (!jit_function_compile (func))
+ {
+ /* Boo! */
+ fail:
+ jit_function_abandon (func);
+ result = NULL;
+
+ /* Be sure to clean up. */
+ while (pc_list != NULL)
+ {
+ struct pc_list *next = pc_list->next;
+ xfree (pc_list);
+ pc_list = next;
+ }
+ }
+ else
+ {
+ /* FIXME bogus cast. */
+ result->function.a0
+ = (Lisp_Object (*) (void)) jit_function_to_closure (func);
+ }
+
+ xfree (stack);
+ xfree (labels);
+ xfree (sw_labels);
+ xfree (stack_depths);
+ eassert (pc_list == NULL);
+
+ return result;
+}
+
+void
+emacs_jit_compile (Lisp_Object func)
+{
+ if (!emacs_jit_initialized)
+ return;
+
+ Lisp_Object bytestr = AREF (func, COMPILED_BYTECODE);
+ CHECK_STRING (bytestr);
+ if (STRING_MULTIBYTE (bytestr))
+ /* BYTESTR must have been produced by Emacs 20.2 or the earlier
+ because they produced a raw 8-bit string for byte-code and now
+ such a byte-code string is loaded as multibyte while raw 8-bit
+ characters converted to multibyte form. Thus, now we must
+ convert them back to the originally intended unibyte form. */
+ bytestr = Fstring_as_unibyte (bytestr);
+
+ ptrdiff_t bytestr_length = SBYTES (bytestr);
+
+ Lisp_Object vector = AREF (func, COMPILED_CONSTANTS);
+ CHECK_VECTOR (vector);
+ Lisp_Object *vectorp = XVECTOR (vector)->contents;
+
+ Lisp_Object maxdepth = AREF (func, COMPILED_STACK_DEPTH);
+ CHECK_FIXNAT (maxdepth);
+
+ jit_context_build_start (emacs_jit_context);
+ struct subr_function *subr = compile (bytestr_length, SDATA (bytestr),
+ XFIXNAT (maxdepth) + 1,
+ vectorp, ASIZE (vector),
+ AREF (func, COMPILED_ARGLIST));
+
+ XVECTOR (func)->contents[COMPILED_JIT_CODE] = (Lisp_Object) subr;
+
+ jit_context_build_end (emacs_jit_context);
+}
+
+DEFUN ("jit-compile", Fjit_compile, Sjit_compile,
+ 1, 1, 0,
+ doc: /* JIT compile a function. */)
+ (Lisp_Object func)
+{
+ struct Lisp_Vector *vec;
+
+ if (!COMPILEDP (func))
+ error ("Not a byte-compiled function");
+
+ vec = XVECTOR (func);
+ if (vec->contents[COMPILED_JIT_CODE] == NULL)
+ emacs_jit_compile (func);
+
+ return Qnil;
+}
+
+DEFUN ("jit-disassemble-to-string", Fjit_disassemble_to_string,
+ Sjit_disassemble_to_string, 1, 1, 0,
+ doc: /* Disassemble a JIT-compiled function and return a string with
the disassembly. */)
+ (Lisp_Object func)
+{
+ char *buffer = NULL;
+ size_t size = 0;
+ FILE *stream;
+ Lisp_Object str;
+ struct Lisp_Vector *vec;
+ jit_function_t cfunc;
+ struct subr_function *sfunc;
+
+ if (!COMPILEDP (func))
+ error ("Not a byte-compiled function");
+
+#ifdef HAVE_OPEN_MEMSTREAM
+ vec = XVECTOR (func);
+ sfunc = (struct subr_function *) vec->contents[COMPILED_JIT_CODE];
+ if (sfunc == NULL)
+ error ("Not JIT-compiled");
+
+ cfunc = jit_function_from_closure (emacs_jit_context, sfunc->function.a0);
+ stream = open_memstream (&buffer, &size);
+ jit_dump_function (stream, cfunc, "Function");
+ fclose (stream);
+
+ str = make_string (buffer, size);
+
+ xfree (buffer);
+ return str;
+#else
+ error ("Cannot disassemble JIT code in this build: open_memstream missing");
+#endif
+}
+
+void
+syms_of_jit (void)
+{
+ defsubr (&Sjit_compile);
+ defsubr (&Sjit_disassemble_to_string);
+ DEFSYM (Qinteractive_p, "interactive-p");
+}
+
+void
+init_jit (void)
+{
+#define LEN SUBR_MAX_ARGS
+
+ jit_type_t params[LEN];
+ int i;
+
+ jit_init ();
+ emacs_jit_context = jit_context_create ();
+
+ if (sizeof (ptrdiff_t) == 8)
+ ptrdiff_t_type = jit_type_ulong;
+ else
+ {
+ eassert (sizeof (ptrdiff_t) == 4);
+ ptrdiff_t_type = jit_type_uint;
+ }
+
+ for (i = 0; i < LEN; ++i)
+ params[i] = jit_type_void_ptr;
+
+ for (i = 0; i < SUBR_MAX_ARGS; ++i)
+ subr_signature[i] = jit_type_create_signature (jit_abi_cdecl,
+ jit_type_void_ptr,
+ params, i, 1);
+
+ nullary_signature = jit_type_create_signature (jit_abi_cdecl,
+ jit_type_void_ptr, params, 0,
+ 1);
+ unary_signature = jit_type_create_signature (jit_abi_cdecl,
+ jit_type_void_ptr, params, 1,
+ 1);
+ binary_signature = jit_type_create_signature (jit_abi_cdecl,
+ jit_type_void_ptr, params, 2,
+ 1);
+ ternary_signature = jit_type_create_signature (jit_abi_cdecl,
+ jit_type_void_ptr, params, 3,
+ 1);
+ specbind_signature = jit_type_create_signature (jit_abi_cdecl,
+ jit_type_void, params, 2, 1);
+ record_unwind_protect_excursion_signature
+ = jit_type_create_signature (jit_abi_cdecl, jit_type_void_ptr, NULL, 0, 1);
+ record_unwind_protect_signature
+ = jit_type_create_signature (jit_abi_cdecl, jit_type_void, params, 2, 1);
+ void_void_signature = jit_type_create_signature (jit_abi_cdecl,
+ jit_type_void, NULL, 0, 1);
+
+ temp_output_buffer_show_signature
+ = jit_type_create_signature (jit_abi_cdecl, jit_type_void_ptr,
+ params, 1, 1);
+
+ params[2] = jit_type_sys_int;
+ arithcompare_signature = jit_type_create_signature (jit_abi_cdecl,
+ jit_type_void_ptr,
+ params, 3, 1);
+
+ params[0] = jit_type_sys_int;
+ unbind_n_signature = jit_type_create_signature (jit_abi_cdecl,
+ jit_type_void_ptr, params, 1,
+ 1);
+
+ params[0] = ptrdiff_t_type;
+ callN_signature = jit_type_create_signature (jit_abi_cdecl,
+ jit_type_void_ptr, params, 2,
+ 1);
+ compiled_signature = callN_signature;
+
+ params[0] = jit_type_sys_int;
+ params[1] = jit_type_sys_int;
+ params[2] = jit_type_sys_int;
+ wrong_number_of_arguments_signature
+ = jit_type_create_signature (jit_abi_cdecl, jit_type_void, params, 3, 1);
+
+ params[0] = jit_type_void_ptr;
+ params[1] = jit_type_void_ptr;
+ params[2] = jit_type_void_ptr;
+ params[3] = jit_type_sys_int;
+ set_internal_signature
+ = jit_type_create_signature (jit_abi_cdecl, jit_type_void, params, 4, 1);
+
+ setjmp_signature = jit_type_create_signature (jit_abi_cdecl,
+ jit_type_sys_int,
+ params, 1, 1);
+
+ params[1] = jit_type_sys_int;
+ push_handler_signature = jit_type_create_signature (jit_abi_cdecl,
+ jit_type_void_ptr,
+ params, 2, 1);
+
+ emacs_jit_initialized = true;
+}
+
+#endif /* HAVE_LIBJIT */
diff --git a/src/lisp.h b/src/lisp.h
index 18d5353..b44d632 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -1891,13 +1891,12 @@ CHAR_TABLE_SET (Lisp_Object ct, int idx, Lisp_Object
val)
char_table_set (ct, idx, val);
}
-/* This structure describes a built-in function.
- It is generated by the DEFUN macro only.
- defsubr makes it into a Lisp object. */
+/* The inner part of a Lisp_Subr, used when calling the function.
+ This is separate so it can be reused by the JIT compiler without
+ requiring an entire Lisp_Subr to be created there. */
-struct Lisp_Subr
+struct subr_function
{
- union vectorlike_header header;
union {
Lisp_Object (*a0) (void);
Lisp_Object (*a1) (Lisp_Object);
@@ -1912,6 +1911,18 @@ struct Lisp_Subr
Lisp_Object (*aMANY) (ptrdiff_t, Lisp_Object *);
} function;
short min_args, max_args;
+ };
+
+#define SUBR_MAX_ARGS 9
+
+/* This structure describes a built-in function.
+ It is generated by the DEFUN macro only.
+ defsubr makes it into a Lisp object. */
+
+struct Lisp_Subr
+ {
+ union vectorlike_header header;
+ struct subr_function function;
const char *symbol_name;
const char *intspec;
EMACS_INT doc;
@@ -2634,7 +2645,8 @@ enum Lisp_Compiled
COMPILED_CONSTANTS = 2,
COMPILED_STACK_DEPTH = 3,
COMPILED_DOC_STRING = 4,
- COMPILED_INTERACTIVE = 5
+ COMPILED_INTERACTIVE = 5,
+ COMPILED_JIT_CODE = 6
};
/* Flag bits in a character. These also get used in termhooks.h.
@@ -2916,8 +2928,8 @@ CHECK_FIXNUM_CDR (Lisp_Object x)
#define DEFUN(lname, fnname, sname, minargs, maxargs, intspec, doc) \
static struct Lisp_Subr sname = \
{ { PVEC_SUBR << PSEUDOVECTOR_AREA_BITS },
\
- { .a ## maxargs = fnname }, \
- minargs, maxargs, lname, intspec, 0}; \
+ { { .a ## maxargs = fnname }, \
+ minargs, maxargs }, lname, intspec, 0}; \
Lisp_Object fnname
/* defsubr (Sname);
@@ -3649,7 +3661,6 @@ build_string (const char *str)
}
extern Lisp_Object pure_cons (Lisp_Object, Lisp_Object);
-extern void make_byte_code (struct Lisp_Vector *);
extern struct Lisp_Vector *allocate_vector (EMACS_INT);
/* Make an uninitialized vector for SIZE objects. NOTE: you must
@@ -3848,7 +3859,9 @@ extern _Noreturn void xsignal3 (Lisp_Object, Lisp_Object,
Lisp_Object,
Lisp_Object);
extern _Noreturn void signal_error (const char *, Lisp_Object);
extern bool FUNCTIONP (Lisp_Object);
-extern Lisp_Object funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs,
Lisp_Object *arg_vector);
+extern Lisp_Object funcall_subr (Lisp_Object error_obj,
+ struct subr_function *subr,
+ ptrdiff_t numargs, Lisp_Object *arg_vector);
extern Lisp_Object eval_sub (Lisp_Object form);
extern Lisp_Object apply1 (Lisp_Object, Lisp_Object);
extern Lisp_Object call0 (Lisp_Object);
@@ -4437,6 +4450,10 @@ extern bool profiler_memory_running;
extern void malloc_probe (size_t);
extern void syms_of_profiler (void);
+/* Defined in jit.c. */
+extern void syms_of_jit (void);
+extern void init_jit (void);
+extern void emacs_jit_compile (Lisp_Object);
#ifdef DOS_NT
/* Defined in msdos.c, w32.c. */
diff --git a/src/lread.c b/src/lread.c
index df2fe58..f2fb8d0 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -2948,8 +2948,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list)
vec = XVECTOR (tmp);
if (vec->header.size == 0)
invalid_syntax ("Empty byte-code object");
- make_byte_code (vec);
- return tmp;
+ return Fmake_byte_code (vec->header.size, vec->contents);
}
if (c == '(')
{
diff --git a/test/src/jit-tests.el b/test/src/jit-tests.el
new file mode 100644
index 0000000..a34f180
--- /dev/null
+++ b/test/src/jit-tests.el
@@ -0,0 +1,304 @@
+;;; jit-tests.el --- unit tests for src/jijt.c -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2018 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/jit.c.
+
+;;; Code:
+
+(require 'ert)
+
+(defun jit-test-apply (func &rest args)
+ (unless (byte-code-function-p (symbol-function func))
+ (byte-compile func))
+ (apply func args))
+
+;; Test Bconsp.
+(defun jit-test-consp (x) (consp x))
+
+(ert-deftest jit-consp ()
+ (should-not (jit-test-apply 'jit-test-consp 23))
+ (should-not (jit-test-apply 'jit-test-consp nil))
+ (should (jit-test-apply 'jit-test-consp '(1 . 2))))
+
+;; Test Blistp.
+(defun jit-test-listp (x) (listp x))
+
+(ert-deftest jit-listp ()
+ (should-not (jit-test-apply 'jit-test-listp 23))
+ (should (jit-test-apply 'jit-test-listp nil))
+ (should (jit-test-apply 'jit-test-listp '(1 . 2))))
+
+;; Test Bstringp.
+(defun jit-test-stringp (x) (stringp x))
+
+(ert-deftest jit-stringp ()
+ (should-not (jit-test-apply 'jit-test-stringp 23))
+ (should-not (jit-test-apply 'jit-test-stringp nil))
+ (should (jit-test-apply 'jit-test-stringp "hi")))
+
+;; Test Bsymbolp.
+(defun jit-test-symbolp (x) (symbolp x))
+
+(ert-deftest jit-symbolp ()
+ (should-not (jit-test-apply 'jit-test-symbolp 23))
+ (should-not (jit-test-apply 'jit-test-symbolp "hi"))
+ (should (jit-test-apply 'jit-test-symbolp 'whatever)))
+
+;; Test Bintegerp.
+(defun jit-test-integerp (x) (integerp x))
+
+(ert-deftest jit-integerp ()
+ (should (jit-test-apply 'jit-test-integerp 23))
+ (should-not (jit-test-apply 'jit-test-integerp 57.5))
+ (should-not (jit-test-apply 'jit-test-integerp "hi"))
+ (should-not (jit-test-apply 'jit-test-integerp 'whatever)))
+
+;; Test Bnumberp.
+(defun jit-test-numberp (x) (numberp x))
+
+(ert-deftest jit-numberp ()
+ (should (jit-test-apply 'jit-test-numberp 23))
+ (should (jit-test-apply 'jit-test-numberp 57.5))
+ (should-not (jit-test-apply 'jit-test-numberp "hi"))
+ (should-not (jit-test-apply 'jit-test-numberp 'whatever)))
+
+;; Test Badd1.
+(defun jit-test-add1 (x) (1+ x))
+
+(ert-deftest jit-add1 ()
+ (should (eq (jit-test-apply 'jit-test-add1 23) 24))
+ (should (eq (jit-test-apply 'jit-test-add1 -17) -16))
+ (should (eql (jit-test-apply 'jit-test-add1 1.0) 2.0))
+ (should-error (jit-test-apply 'jit-test-add1 nil)
+ :type 'wrong-type-argument))
+
+;; Test Bsub1.
+(defun jit-test-sub1 (x) (1- x))
+
+(ert-deftest jit-sub1 ()
+ (should (eq (jit-test-apply 'jit-test-sub1 23) 22))
+ (should (eq (jit-test-apply 'jit-test-sub1 -17) -18))
+ (should (eql (jit-test-apply 'jit-test-sub1 1.0) 0.0))
+ (should-error (jit-test-apply 'jit-test-sub1 nil)
+ :type 'wrong-type-argument))
+
+;; Test Bneg.
+(defun jit-test-negate (x) (- x))
+
+(ert-deftest jit-negate ()
+ (should (eq (jit-test-apply 'jit-test-negate 23) -23))
+ (should (eq (jit-test-apply 'jit-test-negate -17) 17))
+ (should (eql (jit-test-apply 'jit-test-negate 1.0) -1.0))
+ (should-error (jit-test-apply 'jit-test-negate nil)
+ :type 'wrong-type-argument))
+
+;; Test Bnot.
+(defun jit-test-not (x) (not x))
+
+(ert-deftest jit-not ()
+ (should (eq (jit-test-apply 'jit-test-not 23) nil))
+ (should (eq (jit-test-apply 'jit-test-not nil) t))
+ (should (eq (jit-test-apply 'jit-test-not t) nil)))
+
+;; Test Bbobp, Beobp, Bpoint, Bpoint_min, Bpoint_max.
+(defun jit-test-bobp () (bobp))
+(defun jit-test-eobp () (eobp))
+(defun jit-test-point () (point))
+(defun jit-test-point-min () (point-min))
+(defun jit-test-point-max () (point-max))
+
+(ert-deftest jit-bobp-and-eobp ()
+ (with-temp-buffer
+ (should (jit-test-apply 'jit-test-bobp))
+ (should (jit-test-apply 'jit-test-eobp))
+ (insert "hi")
+ (goto-char (point-min))
+ (should (eq (jit-test-apply 'jit-test-point-min) (point-min)))
+ (should (eq (jit-test-apply 'jit-test-point) (point-min)))
+ (should (jit-test-apply 'jit-test-bobp))
+ (should-not (jit-test-apply 'jit-test-eobp))
+ (goto-char (point-max))
+ (should (eq (jit-test-apply 'jit-test-point-max) (point-max)))
+ (should (eq (jit-test-apply 'jit-test-point) (point-max)))
+ (should-not (jit-test-apply 'jit-test-bobp))
+ (should (jit-test-apply 'jit-test-eobp))))
+
+;; Test Bcar and Bcdr.
+(defun jit-test-car (x) (car x))
+(defun jit-test-cdr (x) (cdr x))
+
+(ert-deftest jit-car-cdr ()
+ (let ((pair '(1 . b)))
+ (should (eq (jit-test-apply 'jit-test-car pair) 1))
+ (should (eq (jit-test-apply 'jit-test-car nil) nil))
+ (should-error (jit-test-apply 'jit-test-car 23)
+ :type 'wrong-type-argument)
+ (should (eq (jit-test-apply 'jit-test-cdr pair) 'b))
+ (should (eq (jit-test-apply 'jit-test-cdr nil) nil))
+ (should-error (jit-test-apply 'jit-test-cdr 23)
+ :type 'wrong-type-argument)))
+
+;; Test Bcar_safe and Bcdr_safe.
+(defun jit-test-car-safe (x) (car-safe x))
+(defun jit-test-cdr-safe (x) (cdr-safe x))
+
+(ert-deftest jit-car-cdr-safe ()
+ (let ((pair '(1 . b)))
+ (should (eq (jit-test-apply 'jit-test-car-safe pair) 1))
+ (should (eq (jit-test-apply 'jit-test-car-safe nil) nil))
+ (should (eq (jit-test-apply 'jit-test-car-safe 23) nil))
+ (should (eq (jit-test-apply 'jit-test-cdr-safe pair) 'b))
+ (should (eq (jit-test-apply 'jit-test-cdr-safe nil) nil))
+ (should (eq (jit-test-apply 'jit-test-cdr-safe 23) nil))))
+
+;; Test Beq.
+(defun jit-test-eq (x y) (eq x y))
+
+(ert-deftest jit-eq ()
+ (should (jit-test-apply 'jit-test-eq 'a 'a))
+ (should (jit-test-apply 'jit-test-eq 5 5))
+ (should-not (jit-test-apply 'jit-test-eq 'a 'b))
+ (should-not (jit-test-apply 'jit-test-eq "x" "x")))
+
+;; Test Bgotoifnil.
+(defun jit-test-if (x y) (if x x y))
+
+(ert-deftest jit-if ()
+ (should (eq (jit-test-apply 'jit-test-if 'a 'b) 'a))
+ (should (eq (jit-test-apply 'jit-test-if 0 23) 0))
+ (should (eq (jit-test-apply 'jit-test-if nil 'b) 'b)))
+
+;; Test Bgotoifnilelsepop.
+(defun jit-test-and (x y) (and x y))
+
+(ert-deftest jit-and ()
+ (should (eq (jit-test-apply 'jit-test-and 'a 'b) 'b))
+ (should (eq (jit-test-apply 'jit-test-and 0 23) 23))
+ (should (eq (jit-test-apply 'jit-test-and nil 'b) nil)))
+
+;; Test Bgotoifnonnilelsepop.
+(defun jit-test-or (x y) (or x y))
+
+(ert-deftest jit-or ()
+ (should (eq (jit-test-apply 'jit-test-or 'a 'b) 'a))
+ (should (eq (jit-test-apply 'jit-test-or 0 23) 0))
+ (should (eq (jit-test-apply 'jit-test-or nil 'b) 'b)))
+
+;; Test Bsave_excursion.
+(defun jit-test-save-excursion ()
+ (save-excursion
+ (insert "XYZ")))
+
+;; Test Bcurrent_buffer.
+(defun jit-test-current-buffer () (current-buffer))
+
+(ert-deftest jit-save-excursion ()
+ (with-temp-buffer
+ (jit-test-apply 'jit-test-save-excursion)
+ (should (eq (point) (point-min)))
+ (should (eq (jit-test-apply 'jit-test-current-buffer) (current-buffer)))))
+
+;; Test Bgtr.
+(defun jit-test-> (a b)
+ (> a b))
+
+(ert-deftest jit-> ()
+ (should (eq (jit-test-apply 'jit-test-> 0 23) nil))
+ (should (eq (jit-test-apply 'jit-test-> 23 0) t)))
+
+;; Test Bpushcatch.
+(defun jit-test-catch (&rest l)
+ (catch 'done
+ (dolist (v l)
+ (when (> v 23)
+ (throw 'done v)))))
+
+(ert-deftest jit-catch ()
+ (should (eq (jit-test-apply 'jit-test-catch 0 1 2 3 4) nil))
+ (should (eq (jit-test-apply 'jit-test-catch 20 21 22 23 24 25 26 27 28) 24)))
+
+;; Test Bmemq.
+(defun jit-test-memq (val list)
+ (memq val list))
+
+(ert-deftest jit-memq ()
+ (should (equal (jit-test-apply 'jit-test-memq 0 '(5 4 3 2 1 0)) '(0)))
+ (should (eq (jit-test-apply 'jit-test-memq 72 '(5 4 3 2 1 0)) nil)))
+
+;; Test BlistN.
+(defun jit-test-listN (x)
+ (list x x x x x x x x x x x x x x x x))
+
+(ert-deftest jit-listN ()
+ (should (equal (jit-test-apply 'jit-test-listN 57)
+ '(57 57 57 57 57 57 57 57 57 57 57 57 57 57 57 57))))
+
+;; Test BconcatN.
+(defun jit-test-concatN (x)
+ (concat x x x x x x))
+
+(ert-deftest jit-concatN ()
+ (should (equal (jit-test-apply 'jit-test-concatN "x") "xxxxxx")))
+
+;; Test optional and rest arguments.
+(defun jit-test-opt-rest (a &optional b &rest c)
+ (list a b c))
+
+(ert-deftest jit-opt-rest ()
+ (should (equal (jit-test-apply 'jit-test-opt-rest 1) '(1 nil nil)))
+ (should (equal (jit-test-apply 'jit-test-opt-rest 1 2) '(1 2 nil)))
+ (should (equal (jit-test-apply 'jit-test-opt-rest 1 2 3) '(1 2 (3))))
+ (should (equal (jit-test-apply 'jit-test-opt-rest 1 2 56 57 58)
+ '(1 2 (56 57 58)))))
+
+;; Test for too many arguments.
+(defun jit-test-opt (a &optional b)
+ (cons a b))
+
+(ert-deftest jit-opt ()
+ (should (equal (jit-test-apply 'jit-test-opt 23) '(23)))
+ (should (equal (jit-test-apply 'jit-test-opt 23 24) '(23 . 24)))
+ (should-error (jit-test-apply 'jit-test-opt)
+ :type 'wrong-number-of-arguments)
+ (should-error (jit-test-apply 'jit-test-opt nil 24 97)
+ :type 'wrong-number-of-arguments))
+
+;; Test for unwind-protect.
+(defvar jit-test-up-val nil)
+(defun jit-test-unwind-protect (fun)
+ (setq jit-test-up-val nil)
+ (unwind-protect
+ (progn
+ (setq jit-test-up-val 23)
+ (funcall fun)
+ (setq jit-test-up-val 24))
+ (setq jit-test-up-val 999)))
+
+(ert-deftest jit-unwind-protect ()
+ (jit-test-unwind-protect 'ignore)
+ (should (eq jit-test-up-val 999))
+ (condition-case nil
+ (jit-test-unwind-protect (lambda () (error "HI")))
+ (error
+ nil))
+ (should (eq jit-test-up-val 999)))
+
+;;; jit-tests.el ends here