mirror of
git://git.sv.gnu.org/emacs.git
synced 2026-02-24 05:47:36 +00:00
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.
This commit is contained in:
Tom Tromey
parent
62d9c0cf9c
commit
a166e8fabd
9 changed files with 2825 additions and 73 deletions
37
lisp/emacs-lisp/jit-support.el
Normal file
37
lisp/emacs-lisp/jit-support.el
Normal file
|
|
@ -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
|
||||
43
src/alloc.c
43
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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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 ();
|
||||
|
|
|
|||
92
src/eval.c
92
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),
|
||||
|
|
|
|||
37
src/lisp.h
37
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. */
|
||||
|
|
|
|||
|
|
@ -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 == '(')
|
||||
{
|
||||
|
|
|
|||
304
test/src/jit-tests.el
Normal file
304
test/src/jit-tests.el
Normal file
|
|
@ -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
|
||||
Loading…
Reference in a new issue