From: Tom Tromey Date: Sun, 12 Aug 2018 21:29:43 +0000 (-0600) Subject: JIT compiler X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=a166e8fabda6fbc7a49d2da2c9ae99efc2e3c23e;p=emacs.git 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. --- diff --git a/lisp/emacs-lisp/jit-support.el b/lisp/emacs-lisp/jit-support.el new file mode 100644 index 00000000000..b318f3b607f --- /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 . + +;;;###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 337668f9c31..ca70c0c145d 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 a1215b9d6bf..7a0659da948 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 97205d2b2a2..25493c2d85b 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 8745ba9ef99..de87f9b9532 100644 --- a/src/eval.c +++ b/src/eval.c @@ -30,6 +30,10 @@ along with GNU Emacs. If not, see . */ #include "dispextern.h" #include "buffer.h" +#ifdef HAVE_LIBJIT +#include +#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 00000000000..94a83d2d0fa --- /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 . */ + +#include + +#ifdef HAVE_LIBJIT + +#include "lisp.h" +#include "buffer.h" +#include "bytecode.h" +#include "window.h" + +#include +#include +#include + +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 18d53537cca..b44d6325ba8 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 df2fe581203..f2fb8d070d1 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 00000000000..a34f180f06d --- /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 . + +;;; 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